perm filename GEN[S,AIL]19 blob
sn#069779 filedate 1973-11-10 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00056 PAGES VERSION 17-1(13)
RECORD PAGE DESCRIPTION
00001 00001
00006 00002 HISTORY
00020 00003 LSTON (GEN)
00028 00004 TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
00033 00005 TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
00036 00006 DSCR GENINI
00040 00007 DSCR GETOP, GETADL, GETAD
00042 00008 DSCR -- SAIL DECLARATION EXECS
00047 00009 DSCR TYPSET, VALSET, XOWSET, etc.
00050 00010 DSCR TCON, BTRU, BFAL, BNUL, BINF
00052 00011 DSCR TWID10, ECHK, ESET
00055 00012 DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc.
00063 00013 ↑ENTID:
00069 00014
00075 00015 Check for match on block names.
00076 00016 DSCR RQ00, RQSET, SRCSWT
00080 00017
00081 00018
00087 00019 ↑SRCSWT:
00089 00020 DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF, MACON
00102 00021 DSCR STCAT
00114 00022 DSCR DCLNT1,DCLNT2
00120 00023 DSCR CNDRCY, CNDRCN, CNDRCP
00127 00024 DSCR LETSET, LETENT
00130 00025 DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF
00138 00026 ↑SETWHL: EXCH SP,STPSAV GET STRING POINTER
00151 00027 SUBTTL EXECS for Entry Declaration
00153 00028 DSCR ALOT
00158 00029 ↑ALOT: ROUTINE TO HANDLE ALLOCATION
00162 00030
00166 00031 Comment
00172 00032 NOSY: PUSHJ P,URGSTR IF ON STRING RING....
00181 00033 LOADER BLOCK FOR POLISH FIXUP
00183 00034 DSCR PDOUT
00190 00035 DOLVIN: PUSH P,PNT2
00192 00036 ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS
00197 00037 %AA% -- SDFLTS
00198 00038 Allo -- Allocate One Type of Symbol
00203 00039 ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT
00207 00040 REQINI -- USER REQUIRED INITIALIZTIONS
00210 00041 DSCR DONES
00212 00042
00217 00043 REN <
00219 00044
00223 00045
00228 00046 MEMORY and LOCATION EXECS, ALSO UINCLL
00231 00047 DSCR MAKBUK, FREBUK
00233 00048 BEGIN ERRORS
00239 00049 DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK
00244 00050 DSCR UNDEC -- Undeclared identifiers
00252 00051 DSCR QDEC0,1,2 QARSUB QARDEC QPARM QPRDEC
00259 00052 BEGIN SCOMM
00260 00053 BEGIN INLINE
00262 00054 DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc.
00268 00055
00273 00056 BEGIN COUNT
00276 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 102100000015 ⊗;
COMMENT ⊗
VERSION 17-1(13) 11-10-73 BY KVL INSERT LOG ERR UUO STUFF
VERSION 17-1(12) 11-10-73
VERSION 17-1(11) 10-31-73 BY HJS BUG #OS# DETECT UNDECLARED ARGUMENT TO CVMS
VERSION 17-1(10) 10-30-73 BY RHT BUG #OB# SDFLTS NEEDED TO DO CLRSET
VERSION 17-1(9) 10-23-73 BY JRL FEATURE %AG% ITEM_START STUFF
VERSION 17-1(8) 9-27-73 BY KVL %AC% REMOVE GLOBAL DECLARATION OPTION IN ERROR RECOVERY
VERSION 17-1(7) 9-27-73
VERSION 17-1(6) 9-21-73 BY HJS INHIBIT LISTING OF FALSE PART OF CONDITIONAL COMPILATION
VERSION 17-1(5) 9-19-73 BY HJS ADD CVPS AND EVALREDEFINE
VERSION 17-1(4) 9-1-73 BY RHT FEATURE %AA% -- SPROUT DEFAULTS
VERSION 17-1(3) 8-16-73 BY jrl REMOVE REFERENCES TO LEP SWITCH
VERSION 17-1(2) 8-12-73 BY JRL BUG #NQ# STRING ITEMVAR IS NOT A STRING
VERSION 17-1(1) 8-12-73
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(131) 7-22-73 BY JRL BUG #KU# BAD FIX, ARRAY ITEMS SHOULD NOT BE OWN
VERSION 16-2(130) 7-14-73 BY RHT ADD AN APPL$Y,SETIP,SETCP TO LIBTAB
VERSION 16-2(129) 7-12-73 BY JRL ADD REQUIRE BUCKETS
VERSION 16-2(128) 7-12-73
VERSION 16-2(127) 7-12-73
VERSION 16-2(126) 7-12-73
VERSION 16-2(125) 7-12-73
VERSION 16-2(124) 6-20-73 BY JRL BUG #MS# LET NOT WORKING WHEN RIGHT SIDE A TRIGGERER
VERSION 16-2(123) 6-20-73
VERSION 16-2(122) 6-20-73 BY HJS IFCR, REDEFINE, EVALDEFINE, AND ASSIGNC IMPLEMENTATION
VERSION 16-2(121) 5-9-73 BY HJS REMOP STRING CONSTANTS
VERSION 16-2(120) 5-7-73 BY JRL ADD ERRMSG FOR BAD CONTEXT ELEMENT SYNTAX
VERSION 16-2(119) 5-4-73
VERSION 16-2(118) 5-4-73
VERSION 16-2(117) 5-4-73
VERSION 16-2(116) 4-23-73
VERSION 16-2(115) 4-23-73 BY RHT CHANGE PROC DESC FOR PROC ARGS
VERSION 16-2(114) 4-23-73
VERSION 16-2(113) 4-22-73 BY RHT FIX UNDISCOVERED LVI BUG
VERSION 16-2(112) 4-21-73 BY RHT BUG #MC#
VERSION 16-2(111) 3-22-73 BY RHT ADD DEFAULT VALUES FOR PARAMS
VERSION 16-2(110) 3-20-73 BY RHT CHANGE FORMAL SEMBLK DELETION
VERSION 16-2(109) 3-19-73 BY HJS ALLOW TEMPORARY OVERRIDING OF NULL DELIMITERS MODE
VERSION 16-2(108) 3-13-73 BY JRL REMOVE SLS,WOM,NODIS,GAG CONDITIONAL
VERSION 16-2(107) 3-7-73 BY KVL ADD ACCESS CONSTRUCT FEATURE
VERSION 16-2(107) 3-6-73 BY JRL ADD ALLGLOBAL REQUIRE
VERSION 16-2(106) 3-5-73 BY JRL ADD OKSTAC TO DCLBEG
VERSION 16-2(105) 2-27-73 BY JRL REMOVE ..RVAL FROM LIBTAB
VERSION 16-2(104) 2-21-73 BY RHT ADD EXEC TYPMSG (P19) FOR REQUIRE STC MESSAGE
VERSION 16-2(103) 2-12-73 BY JRL ADD ..RVAL TO LIBTAB
VERSION 16-2(102) 1-28-73 BY JRL REMOVE BOUND FROM SYNTAX
VERSION 16-2(101) 1-26-73 BY JRL ADD INCONT TO LIBTAB
VERSION 16-2(100) 1-26-73 BY JRL ADD ERRMSG FOR SAMEIV AND IN_CONTEXT
VERSION 16-2(99) 1-25-73 BY JRL HALF-KILL ITEMS WITH NOS. < 20
VERSION 16-2(98) 1-25-73 BY JRL MOD ERRMSG ERR112 TO INCLUDE ?
VERSION 16-2(97) 1-24-73 BY KVL INSTALL ENTENT EXEC, MAKING DUMMY SYMBOLS TO ENTRY UNNECESSARY
VERSION 16-2(96) 1-9-73 BY RHT BUG #KT# TYPO IN UP
VERSION 16-2(95) 1-9-73 BY RHT BUG #KY# ALLOW GLOBAL INTERNAL SYMBOLS TO GO OUT ALWAYS
VERSION 16-2(94) 1-9-73 BY RHT BUG #KX# NEED ALLSTO BEFORE BEXIT
VERSION 16-2(93) 1-8-73 BY JRL BUG KW DON'T ALLOW INTERNAL OR EXTERNAL ITEM DECLARATIONS
VERSION 16-2(92) 1-8-73
VERSION 16-2(91) 1-8-73
VERSION 16-2(90) 12-13-72 BY HJS FIX RACE CONDITION WHERE MACROS AND CONDITIONAL COMPILATION END SIMULTANEOUSLY
VERSION 16-2(89) 12-11-72 BY HJS ENDC PARSER SWITCH TRIGGER IN WHILEC, CASEC, FORC, AND FORLC BODIES
VERSION 16-2(88) 12-2-72 BY HJS SAVE VALUE OF BITS DURING CONDITIONAL COMPILATION AND MACRO DEFINITION
VERSION 16-2(87) 11-30-72 BY RHT ADD LIBTAB ENTRIES FOR POLLING
VERSION 16-2(86) 11-28-72 BY RHT ADD CODE FOR CLEANUPS
VERSION 16-2(85) 11-24-72 BY RHT BUG #KM# TYPO MESSED UP POLISH FIXUP FOR EXT PD
VERSION 16-2(84) 11-21-72 BY JRL BAD JRST IN INMAIN
VERSION 16-2(83) 11-20-72 BY KVL REMOVE ER51 - MEANINGLESS MSG. IF YOU WANT IT, SEE ME.
VERSION 16-2(82) 11-19-72 BY HJS DLMPSH AND DLMPOP FOR PROPER HANDLING OF DEFINES WITHIN DEFINES
VERSION 16-2(81) 11-17-72 BY RHT ADD CALL TO USER INITIALIZATION
VERSION 16-2(80) 11-15-72 BY HJS INSERT DEFDLM QSTACK ROUTINES FOR DEFLUK BIT OF FF FOR COMPILE-TIME MACROS WITHIN MACROS
VERSION 16-2(79) 11-15-72 BY KVL SURPRESS CODE GENERATION AFTER SERIOUS ERRORS.
VERSION 16-2(78) 11-10-72 BY HJS ADD DLMSTG STACK SO MACROS DEFINED WITHIN MACROS WITH CONCATENATION WILL WORK
VERSION 16-2(77) 11-10-72 BY JRL ADD ERR MSG FOR PROPS AND LIBTAB ENTRIES
VERSION 16-2(76) 11-8-72 BY HJS IMPLEMENTATION OF CHECK_TYPE
VERSION 16-2(75) 11-7-72 BY JRL GIVE ERROR MESSAGE BAD USE OF BIND
VERSION 16-2(74) 11-2-72 BY RHT BUG #JY# TYPE CHECKING ON MEMORY INDEX
VERSION 16-2(73) 11-2-72 BY JRL ADD MAINPR TO LIBTAB
VERSION 16-2(72) 10-24-72 BY JRL ADD INMAIN EXEC TO INIT MAINPR
VERSION 16-2(71) 10-22-72 BY RHT BUG #JU# FIX UP ACKTAB ENCLOBERMENT BY QUICK_CODE
VERSION 16-2(70) 10-20-72 BY RHT BUG #JV# MEMORY TRIED TO USE AC 0 AS INDEX
VERSION 16-2(69) 10-20-72 BY RHT PROVIDE EXTRA ENTRY POINTS IN REQINI
VERSION 16-2(68) 10-17-72 BY AM HJS IMPLEMENTATION OF DECLARATION FEATURE FOR TYPE CHECKING AT COMPILE TIME
VERSION 16-2(67) 10-12-72 BY HJS BUG #JP# AND CVMS IMPLEMENTATION
VERSION 16-2(66) 10-10-72 BY KVL FIX ; ELSE RECOVERY
VERSION 16-2(65) 10-5-72 BY JRL PREPARE FOR EXPO
VERSION 16-2(64) 10-5-72 BY KVL MAKE UNDECLARED IDENTIFIERS AN ERR.
VERSION 16-2(63) 9-29-72 BY RHT BUG #JH# FIX TYPO IN REQINI
VERSION 16-2(62) 9-27-72 BY HJS FORCE EXECUTION OF BLOCK WHEN A DEFINE IS THE ONLY DECLARATION IN THE BEGINNING OF A BLOCK.
VERSION 16-2(61) 9-27-72 BY RHT BUG #JF# MESSAGE PROC LINK GETTING WRONG ADDRESS
VERSION 16-2(60) 9-27-72 BY JRL ADD ARYSET,SAFSET EXECS FOR DATUMS
VERSION 16-2(59) 9-25-72 BY RHT BUG #IZ# GLOBAL STUFF SHOULD STAY OUT OF PD
VERSION 16-2(58) 9-22-72 BY RHT BUG #IV# UNDEC FWRD MESSAGE PROC PD BUG
VERSION 16-2(57) 9-21-72 BY RHT MAKE THE LOCN PUT THING INCOR
VERSION 16-2(56) 8-24-72 BY RHT ADD CAUSE & INTERROGATE TO XCALL TABLE
VERSION 16-2(55) 8-23-72 BY JRL ADD BEXIT CODE FOR CONTEXT
VERSION 16-2(54) 8-22-72 BY RHT PREVENT DOUBLE ALLOCATION OF KILL SET
VERSION 16-2(53) 8-18-72 BY JRL CHANGE TYPPRO TO HANDLE MATCHING PROCEDURES
VERSION 16-2(52) 8-14-72 BY RHT EXEC FOR LOCATION(X)
VERSION 16-2(51) 8-14-72 BY RHT EVAL →→ APPLY
VERSION 16-2(50) 8-14-72 BY RHT ADD EXECS FOR MEMORY
VERSION 16-2(49) 8-11-72 BY RHT MAKE POLISH FIXUP TO GET AT EXTERNAL PD'S
VERSION 16-2(48) 8-11-72 BY JRL ADD REMEMBER ETC TO LIBTAB
VERSION 16-2(47) 8-4-72 BY RHT BUG #IT# EXTERNALS IN THE PD
VERSION 16-2(46) 8-1-72 BY RHT MAKE KILL SETS REAL SETS
VERSION 16-2(45) 7-28-72 BY RHT CHANGE FORKER TO SPROUT
VERSION 16-2(44) 7-26-72 BY HJS TURN OFF MACRO EXPANSION WHEN SCANNING FORMAL PARAMETERS.
VERSION 16-2(43) 7-25-72 BY RHT FIX THE PD SYMBOL
VERSION 16-2(42) 7-24-72 BY RHT PUT FORKER IN LIST OF XCALLED FNS
VERSION 16-2(41) 7-24-72 BY RHT PUT OUT SYMBOL FOR PD
VERSION 16-2(40) 7-22-72 BY RHT ADD KILL LISTS
VERSION 16-2(39) 7-9-72 BY RHT NO PD IF NO DADDY
VERSION 16-2(38) 7-5-72 BY DCS BUG #II# DON'T LET DEFINES OUT AS SYMBOLS
VERSION 16-2(37) 7-2-72 BY JRL SET LEAPIS IF ANY LEAP FUNCTIONS USED
VERSION 16-2(36) 6-25-72 BY DCS BUG #HX# PARAMETERIZE OPCODE FILE NAMES (AND OTHERS)
VERSION 16-2(35) 6-21-72 BY RHT CHANGE WAY PDA,,0 SEMBLK IS LINKED
VERSION 16-2(34) 6-14-72 BY JRL BUG ##H#S# STRING ITEMVAR PROCS ARE NOT STRING PROCS.
VERSION 16-2(32) 6-8-72 BY RHT MAKE ENTRY IN LIBTAB FOR EVAL
VERSION 16-2(31) 5-16-72 BY RHT GIVE ERR IF SIMPLE PROC ALLOCATES
VERSION 16-2(30) 5-16-72 BY RHT TO HANDLE OWN VARS IN BLOCKS--ENTID
VERSION 16-2(29) 5-14-72 BY DCS BUG #HH# BETTER INITIAL CODE IF /H
VERSION 15-6(7-28) 4-20-72 LOTS OF THINGS
VERSION 15-2(6) 2-21-72 BY HJS THE BRAVE NEW PARSER WORLD
VERSION 15-2(5) 2-6-72 BY DCS BUG #GN# UUOS TO START_CODE TABLE, FIX BOUNDARY COND.
VERSION 15-2(4) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(3) 2-5-72 BY DCS BUG #GI# ADD CAT ROUTS TO LIBFSN (CHRCAT, ETC.)
VERSION 15-2(2) 2-1-72 BY DCS ISSUE NEW STYLE %ALLOC SPACE REQUESTS
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
⊗;
LSTON (GEN)
BITD2DATA (EMITTER)
; EMITTER BITS -- PUT DESCRIPTORS IN POSITION TO BE EXAMINED BY $L OPERATIONS
↑GENBTS:
BIT (NOUSAC,400000) ;DON'T USE D(RH) AS AC #
BIT (USCOND,200000) ;USE C(RH) AS 3 BITS OF CONDITION
BIT (USADDR,100000) ;USE C(LH) AS DISPLACEMENT PART
BIT (USX , 40000) ;USE D(LH) AS INDEX REG
BIT (NORLC , 20000) ;RELOCATE NOT!
BIT (IMMOVE, 10000) ;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
BIT (INDRCT, 4000) ;INDIRECT ADDRESSING REQUIRED
BIT (JSFIX , 2000) ;JUST DO A FIXUP (DON'T GET SEMANTICS).
BIT (NOADDR, 1000) ;NO EFFECTIVE ADDRESS PART
BIT (EMADDR,400) ;WE WANT THE ADDRESS OF THIS ENTITY
BIT (PNTROP, 200) ;INTERNAL OPERATION INDICATING POINTER INDEXING
BIT (FXTWO, 100) ;USE SECOND FIXUP WORD
BLOCK 6 ;LEFT OVER BITS
BITD2DATA (GENMOV)
;CONTROL BITS PASSED TO GENMOV IN THE RIGHT HALF OF "FF".
;FOR COMMENTS, SEE THE FILE "TOTAL".
BIT (INSIST,400000) ;INSIST ON DOING TYPE CONVERSION.
;THE RIGHT HALF OF "B" CONTAINS TYPE BITS.
BIT (ARITH,200000) ;INSIST ARGUMENT IS AN ARITHMETIC TYPE.
BIT (EXCHIN,100000) ;DO AN EXCHOP ON THE WAY INTO THE ROUTINE.
BIT (EXCHOUT,40000) ;DO AN EXCHOP ON THE WAY OUT OF A ROUTINE.
BIT (GETD,20000) ;DO A GETAD BEFORE DOING THIS ROUTINE.
BIT (SPARE,10000) ;NEGAT←← 10000 ;GET THE OPERAND IN NEGATIVE FORM.
BIT (POSIT,4000) ;INSIST ON THE OPERAND IN POSITIVE FORM.
BIT (BITS2,2000) ;UPDATE SBITS2 FROM $SBITS2(PNT2) ON WAY OUT.
BIT (MRK,1000) ;MARK THE ACCUMULATOR MENTIONED IN D WITH THE ARGUMENT.
;(DONE AT END OF MAIN OPERATION)
;THIS MEANS "GENERATE A TEMP CELL IF NECESSARY."
BIT (ADDR,400) ;SAME BIT AS GENERATOR USES. USE THE ADDRESS OF ARG.
BIT (REM,200) ;REMOP ON THE WAY OUT.
BIT (NONSTD,100) ;NON-STANDARD OPERATION.
BIT (SPAC,40) ;WE HAVE A SPECIFIC AC NUMBER IN MIND.
BIT (PROTECT,20) ;PROTECT THIS ACCUMULATOR.
BIT (UNPROTECT,10) ;UNPROTECT THIS ACCUMULATOR.
BIT (DBL,2) ;NEED A DOUBLE ACCUMULATOR.
BIT (INDX,1) ;NEED AN INDEXABLE ACCUMULATOR.
BITDATA (STROP)
; BITS TO BE PASSED TO STROP IN A
; SEE STROP FOR MEANINGS OF THESE BITS.
↓BPWORD ←← 400000
↓LNWORD ←← 200000
↓BPFIRST ←← 100000
↓ADOP ←← 40000
↓SBOP ←← 20000
↓UNDO ←← 10000
↓STAK ←← 4000
↓BPINC ←← 2000
ZERODATA (EXEC ROUTINES -- GLOBAL VARIABLES)
COMMENT ⊗
ADEPTH -- Whenever code is generated to push something onto the
System stack (P, usually 17), currently only when an actual
parameter is put on, this is incremented. It is added to
the displacement for a formal parameter whenever it is ref-
erenced. This allows the access code to get to the right
stack element for a parameter, no matter what's on the stack.
ADEPTH is decremented when things come off. It is restarted
whenever a procedure declaration is encountered (first checked,
since it should always be 0 at that point).
⊗
↓ADEPTH: 0
;APARNO -- a count of the number of non-string parameters in
; the current procedure -- used to set up the $NPRMS word
; in the 2d Semblk for the procedure
↓APARNO: 0
;DEFRN1 -- Semantics of first formal macro param in VARB-Ring
; while scanning macro params. Used to release all the
; Semblks for these params when done with them.
↓DEFRN1: 0
COMMENT ⊗
FALLOC -- Semantics of a [0] integer constant, created the
first time the word FALSE appears in source -- FALSE
thenceforth equated to this [0] constant, since the two
are internally equivalent -- see BFAL routine
⊗
↓FALLOC: 0
;GLOBCNT -- used in ENTID to count # global items declared
↓GLOBCNT: 0
;LENCNT -- AOS'ed whenever substring operation is begun, SOS'ed
; when it is complete. BINF (∞≡length(str) EXEC) checks
; this to make sure there's a string to take the length of.
↓LENCNT: 0
;LENSTR -- QSTACK descriptor -- each entry is Semantics of a
; string being SUBSTRd. Kept here for convenience of BINF,
; so that it doesn't have to search up the stack for it.
↓LENSTR: 0
;NULLOC -- Semantics of "", for BNUL (NULL ≡ "" EXEC)
↓NULLOC: 0 ;SEE FALLOC, TRULOC
;OPCODE -- for binary operations, proper opcode (and control bits),
; fetched from one of the OP tables (PMTAB, TDTAB, MXMNTB) via the
; class code in the production which called the EXEC. Used as tem-
; plate for output instruction. Stored in OPCODE for convenience
↓OPCODE: 0
;SDEPTH -- ADEPTH-type count for String stack -- bumped not only for
; actual params, but also for String Procedure results, other
; String operations which use the stack.
↓SDEPTH: 0
;SPARNO -- APARNO-type count of String formals -- it's possible that
; this is doubled before use, since there are two words for each
; String descriptor. See PROCED, ENTID for uses.
↓SPARNO: 0
;THISE -- Set by ECHK EXEC, remembers type of expression, since two
; class codes are passed in from PARSER
; (e.g., EXEC @E ECHK @class randomexec)
↓THISE: 0
;TRULOC -- Semantics of [-1], used by BTRU (TRUE≡≠0 EXEC)
↓TRULOC: 0
TABLEDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
COMMENT ⊗
LIBTAB -- table of fixups (current ends of chains) for routines
called by SAIL programs to accomplish complicated operators
(CAT, SUBSTR, ARRMAK, etc.) -- the LIBFSN macro, with the
appropriate definition of the FN macro, puts out a symbolic
index into this table for each name mentioned (R&ROUTNAME),
and a word of table to hold the fixup. It is used again below
(LIBNAM) to create a table of corresponding External RADIX50
request words which will be used in DONES to put out the chain
requests. The XCALL and LPCALL macros are used to put out
(fixup chained) calls to these routines.
⊗
DEFINE LIBFSN <
FN <CAT> ;STRING CONCATENATIONS.
FN <CHRCAT> ;INTEGER&STRING
FN <CATCHR> ;STRING&INTEGR
FN <CHRCHR> ;INTEGR&INTEGR
FN <CAT.RV> ;STRING&STRING, 2D ARG FIRST
FN <SUBSR> ;SUBSTRING (FOR)
FN <SUBST> ;SUBSTRING (TO)
; FN <SUBSI> ;EXTINCT (USED TO BE SUBSTRING INF)
FN <GETCH> ;CONVERT FIRST CHAR OF STRING TO INTEGER
FN <PUTCH> ;CONVERT LOW ORDER 7 BITS TO STRING
FN <POW> ;EXPONENTIATION
FN <FPOW> ;FLOATING ARG, INTEGER EXPONENT.
FN <LOGS> ;INTEGER ARG,FLOATING EXPONENT.
FN <FLOGS> ;FLOATING ARG, FLOATING EXPONENT.
FN <ARMRK> ;MARK THE ARRAY PUSHDOWN STACK.
FN <ARMAK> ;MAKE AN ARRAY (PARAMS IN STACK)
FN <ARREL> ;RELEASE ARRAYS BACK TO LAST MARK ON STACK.
FN <LEAP> ;CALL LEAP!
FN <DATM> ;THIS IS REFERENCE TO A WORD WHICH IS XWD 3,→
; BASE OF DATUM TABLE.
FN <LPRYER> ;DATUM(X) WAS NULL, WHEN AN ARRAY WAS EXPECTED.
FN <PROPS> ;THE PROPS BYTE POINTER POINT 9,INFOTAB(3),35
GLOC <
FN <GPROPS> ;GLOBAL PROPS
FN <GDATM> ;GLOBAL DATUM
FN <.MES1>
FN <.MES2>
FN <DATERR>
>;GLOC
FN <PITBND> ;BIND PD TO ITEM
FN <PITCOP> ;COPY PROC ITEM
FN <PITDTM> ;-1(P)←DATUM(-1(P))
FN <APPLY> ;INTERP CALLER
FN <SPROUT> ;SPROUTER
FN <CAUSE> ;CAUSES EVENTS
FN <INTERROGATE> ;INTERROGATE FUNCTION
FN <MAINPR> ;INITIALIZE PROCESSES
FN <BEXIT> ;BLOCK EXITER
FN <STKUWD> ;STACK UNWINDER
FN <CSERR> ;CASE STATEMENT INDEX OUT OF BOUNDS
FN <ALLRM> ;REMEMBER ALL
FN <ALLFOR> ;FORGET ALL
FN <ALLRS> ;RESTORE ALL
FN <REMEMB> ;REMEMBER
FN <FORGET> ;FORGET
FN <RESTOR> ;RESTORE
FN <.INCON> ;IN_CONTEXT
FN <CONELM> ;C:VAR
FN <.SUCCE> ;SUCCEED (FOR MATCH. PROCS)
FN <.FAIL> ;FAIL
FN <.UINIT> ;USER INITIALIZATIONS
FN <DDFINT> ;DO DEFERED INTERRUPT
FN <INTRPT> ;SET ≠0 WHEN HAVE AN INTERRUPT
FN <APPL$Y> ;USED WITH SPROUT APPLY
FN <SETIP> ;
FN <SETCP> ;
>
DEFINE FN '(X) <
↓R'X ←← LIBNUM
↓LIBNUM ←← LIBNUM+1
0 ;FIXUP WORD.
>
↓LIBNUM←←0
↓LIBTAB: LIBFSN ;FIXUPS FOR LIBRARY FUNCTIONS.
; the current procedure -- used to set up the $NPRMS word
TABCONDATA (EXEC ROUTINES -- GLOBAL VARIABLES)
COMMENT ⊗
LIBNAM -- these are the external request symbols for the
above-mentioned runtime routines -- see LIBTAB, above
⊗
DEFINE FN (X) < RADIX50 60,X >
LIBNAM: LIBFSN
>
COMMENT ⊗
TYPTAB, VALTAB, XOTAB
These tables are used by the TYPSET, VALSET, XOWSET routines
to convert the class codes from the PARSER, specifying which
data type, REFERENCE or VALUE type, or modifier (SAFE, etc.)
is being requested, to the appropriate TBITS bit. These three
routines are, as might be guessed, EXEC routines.
⊗
↑TYPTAB:
HELITM: ITEM ;ITEM
HELITV: ITMVAR ;ITEMVAR
0+SET ;SET
LABEL+FORWRD ;LABEL
FLOTNG ;REAL
INTEGR ;INTEGER
STRING ;STRING
INTEGR ;BOOLEAN
0+SET+LSTBIT ;LIST
XWD SAFE,SET!INTEGR ;KILL_SET
0+SET!FLOTNG ;CONTEXT
XOTAB: XWD INTRNL,0 ;INTERNAL
XWD SAFE,0 ;SAFE
XWD EXTRNL,0 ;EXTERNAL
XWD OWN,0 ;OWN
XWD RECURS,0 ;RECURSIVE
XWD EXTRNL,FORTRAN ;FORTRAN
FORWRD ;FORWARD
SHORT ;SHORT
XWD SIMPLE,0 ;SIMPLE
XWD MPBIND,INTEGR ;MATCHING
GLOC <
GLOBL ;GLOBAL LEAP TYPE.
XWD MESSAGE,0 ;MESSAGE
>;GLOC
VALTAB: XWD REFRNC,0 ;REFERENCE
XWD VALUE,0 ;VALUE
XWD VALUE!MPBIND,ITMVAR ;? PARAMETER
CHKTAB: XWD RES,0 ; RESERVED
XWD BILTIN,0 ; BUILTIN FUNCTION
LPARRAY ; LEAP ARRAY
XWD SBSCRP,0 ; NORMAL ARRAY
XWD DEFINE,0 ; DEFINE
PROCED ; PROCEDURE
ENDDATA
SUBTTL EXEC (GENERATOR) INITIALIZATION
DSCR GENINI
CAL PUSHJ from SAIL Exec
RES Initializes variables for whom the EXECS (generators)
have main responsibility. Calls RELINI and LEPINI to set
up Relfile and Leap variables
SEE SAIL Exec, RELINI, LEPINI
⊗
↑GENINI:
II←←10 ;LONGER STARTUP
;* * * * * *
REN <
SETOM INHIGH ;WILL BE IN HIGH FIRST IF HISW
MOVEI TEMP,1
MOVEM TEMP,HCNT ;DATA STARTS AT 1 IF HISW
>;REN
MOVEI TEMP,II ;START HERE
REN <
SKIPE HISW ;TWO-SEGMENT COMPILATION?
MOVEI TEMP,400000+II ;YES, CODE STARTS HERE
>;REN
MOVEM TEMP,PCNT
;;#HH# 5-14-72 DCS (2-2) ACCOUNT FOR UPPER SEGMENT CODE
REN <
MOVEI TEMP,5-II(TEMP) ;NOW ADJUST INITIAL PD PUSH DATA
HRRM TEMP,IPDFIX ;SEE SAIL FOR THIS ARCHBLOCK
>;REN
;;#HH# (2-2)
Comment ⊗ The first words of code are (for main programs)
0 SKIPA ;NON-RPGMODE START
1 SETOM RPGSW ;RPG MODE
2 JSR SAILOR ;INITIALIZE
3 HRLOI RF,1 ;FOR FAKE F LINK
4 PUSH P,RF
5 PUSH P,[PDA,,0] ;PDA OF OUTER BLOCK & USELESS STATIC LINK
6 PUSH P,SP ;REST OF MSCP
7 HRRZI RF,-2(P) ;POINT THERE
⊗;
; MARK TOP AC'S UNUSABLE FOR GENERAL ALLOCATION
FOR II⊂(RSP,RP,USER,TEMP,LPSA,RF) <
SETOM ACKTAB+II>
; ***** THIS CODE MOVED TO RELOUTPUT AREA IN TOTAL
PUSHJ P,RELINI ;INITIALIZE LOADER FILE VAIRIABLES
; *****
IFN FTDEBUG <
MOVE TEMP,BITABLE
EXTERNAL $M
MOVEM TEMP,$M+3 ;RAID LOC
>
; ***** THIS CODE MOVED TO LEAP
PUSHJ P,LEPINI ;INITIALIZE LEAP VARIABLES
; ******
POPJ P,
REN <
DSCR HISET, LOSET, SWIT -- Call to Get Correct PCs into PCNT and HCNT
DES Calling HISET makes sure code will go to upper segment.
Calling LOSET makes sure it will go to lower segment
Calling SWIT does HISET if LOSET was last, LOSET if HISET was last.
⊗
↑HISET: SKIPE INHIGH ;ALREADY IN HIGH SEGMENT?
POPJ P, ;YES, DONE
JRST SWIT ;NO, GO IN
↑LOSET: SKIPE INHIGH ;ALREADY IN LOW SEGMENT OR
↑SWIT: SKIPN HISW ; IS THIS RELEVANT?
POPJ P, ;YES OR NO
SETCMM INHIGH ;IF IN, NOW OUT AND VICE VERSA
PUSHJ P,FRBT ;FORCE OUT BINARY IN OTHER SEGMENT
MOVE TEMP,PCNT ;EXCHANGE PCS
EXCH TEMP,HCNT
MOVEM TEMP,PCNT
POPJ P, ;DONE
>;REN
DSCR GETOP, GETADL, GETAD
DES Routines to pick things up from symbol table blocks.
GETOP is the entry which also picks up the
generator stack entry specified by accumulator A.
⊗
↑GETAD2: SKIPN PNT2
ERR <DRYROT -- GETAD>
MOVE SBITS2,$SBITS(PNT2)
MOVE TBITS2,$TBITS(PNT2)
POPJ P,
↑GETAD: JUMPN PNT,GETSTF ;TEST FOR NULL SEMANTICS.
ERR <DRYROT -- GETAD>
↑GETADL: SKIPN PNT,LPSA ;MAKE SURE WE HAVE A GOOD ENTRY
ERR <DRYROT -- GETAD>
GETSTF: MOVE SBITS,$SBITS(PNT)
MOVE TBITS,$TBITS(PNT) ;BOTH BITS WORDS
POPJ P,
BEGIN GENDEC
SUBTTL EXECS for typing variables, equating TRUE with -1, etc.
DSCR -- SAIL DECLARATION EXECS
DES These are the declarations routines.
They take care of simple identifier declarations
as well as procedures, arrays, etc. If a "BEGIN"
is seen, the varb structure recurrs out of the current
block, a new one is created, the VARB list is updated to the
new block, and a new symbol table bucket is made.
The reverse is effected when an "END" is seen which
matches a BEGIN which involved declarations.
For procedures, a similar thing happens.
⊗
DSCR TYPDEC, TYPAR, TYPPRO, etc.
PRO TYPDEC TYPAR TYPPRO TYPR1 PRST
DES The routines to "type" an entity and return an appropriate
parser token. Thus, the parser can be aware of the types of
user identifiers. This speeds up operations somewhat, and means
that the parser can do much of the "semantic" type-checking.
⊗
↑TYPDEC: HRLI A,CLSIDX ;ALL VARIABLES ARE CLASS MEMBERS
TLNE TBITS,CNST ;a constant ?
JRST MYCON
TLNE TBITS,SBSCRP ;ARRAY?
JRST ARLO ;YES
TRNE TBITS,ITEM+ITMVAR+PROCED
JRST TYPDES ;DESCRIMINATE
HRRI A,TICTXT
TRNE TBITS,FLOTNG
TRNN TBITS,SET
CAIA
POPJ P,
HRRI A,TIST ;SET
TRNE TBITS,SET
POPJ P,
HRRI A,TIVB
TRNE TBITS,INTEGR+FLOTNG+DBLPRC
POPJ P,
HRRI A,TISV ;STRING VARIABLE
TRNE TBITS,STRING
POPJ P,
HRRI A,TILB ;LABEL
TRNE TBITS,LABEL
POPJ P,
TROUBL: HRRI A,TI ;UNDECLARED IDENTIFIER
POPJ P,
TYPDES: HRRI A,TIPR ;PROCEDURE
TRNE TBITS,PROCED
POPJ P,
HRRI A,TIIT ;ITEM
TRNE TBITS,ITEM
POPJ P,
HRRI A,TITV ;ITEMVAR
TRNE TBITS,ITMVAR
POPJ P,
JRST TROUBL
ARLO: HRRI A,TIAR ;ARITHMETIC OR ITEM ARRAY.
POPJ P, ;ARITHMETIC OR ITEM ARRAY
MYCON: HRRI A,TICN ;ARITHMETIC CONTSTANT
TRNE TBITS,STRING ;MIGHT BE STRING
HRRI A,TSTC ;STRING CONSTANT.
POPJ P,
↑TYPAR: ;TYPE AN ARRAY
↑TYPPRO: TDZA B,B ;INDEX INTO GENRIG,PARIG
↑TYPR1: MOVEI B,1
SKIPN LPSA,GENRIG(B) ;SEMANTICS
ERR <UNTYPED PROCEDURE AS EXPRESSION>,1,<[TRO TBITS,INTEGR
JRST TYPESS]>
TYA1: PUSHJ P,GETADL ;GET GOOD BITS
TLNE TBITS,MPBIND ;MATCHING PROCEDURE
TLNN FF,LPPROG ;AND FOREACH IN PROGRESS
CAIA
POPJ P,
TRZ TBITS,PROCED ;TURN OFF PROCEDURE
TLZ TBITS,-1
TRNN TBITS,ALTYPS ;ANYTHING THERE?
TYPER: JRST [HRLI A,CLSIDX ;WE FAKE AN INTEGER
HRRI A,TIVB
JRST TYPESS]
PUSHJ P,TYPDEC ;TYPE BIT
TYPESS: MOVEM A,PARRIG(B) ;PUT DOWN THE ANSWER
POPJ P,
↑PRST: SKIPN PNT,GENRIG
POPJ P, ;PROCEDURE WAS UNTYPED....
MOVE TBITS,$TBITS(PNT) ; TYPE.
;;#HS# JRL 6-14-72 A STRING ITEMVAR IS NOT A STRING
TRNE TBITS,ITMVAR!ITEM
JRST REMOP
;;#HS#
TRNE TBITS,STRING ;IF OF TYPE STRING, COMPLAIN.
JRST SUBIT ;DOWN IN TOTAL -- SUBTRACTS FROM STACK.
JRST REMOP
DSCR TYPSET, VALSET, XOWSET, etc.
PRO TYPSET XOWSET VALSET HELAR2 HELAR1 HELARY CLRSET PRSET
DES EXECS to collect type bits as they are specified
The standard mechanisms for entering variables.
Little routines are called to turn on the right bits
in the "BITS" word for ENTERS to eventually use
⊗
;RECORD ANY MODIFIERS ON THE DECLARATIONS.
;CALLED WITH CLASS INDEX TYPE IN REGISTER B.
↑XOWSET: SKIPA A,XOTAB(B) ;PICK UP TABLE ENTRY
↑VALSET: MOVE A,VALTAB(B) ;INDEXED BY "B" PASSED FROM PARSER
IORM A,BITS
POPJ P, ;RETURN
↑ARYSET: SKIPA A,[LPARRAY]
↑SAFSET: MOVEI A,SAFE ;SAFE BIT
IORM A,BITS ;SAVE IT
POPJ P,
↑HELAR2: MOVE B,BITS
;; #KU# DON'T MAKE ARRAY ITEMS OWN
TRO B,ITEM ;SO HELSPC WILL KNOW NOT TO MAKE OWN
PUSHJ P,HELSPC ;SPECIAL FOR ARRAY ITEMS.
TDZA B,B ;ITEM .......
↑HELAR1: MOVEI B,1
↑HELARY: MOVEI A,LPARRAY ;SAY A LEAP TYPE ARRAY.
IORM A,BITS ;AND FALL THROUGH TO TYPE IT.
↑HELSET:
↑TYPSET: MOVE A,TYPTAB(B) ;ORDINARY TYPES.
IORB A,BITS
MOVEM A,ARYBIT ;AND RECORD SHOULD AN ARRAY BE DECLARED.
POPJ P,
↑CLRSET: SETZM BITS ;ZERO FOR A NEW TYPE
POPJ P,
↑PRSET: MOVEI A,PROCED
IORM A,BITS
POPJ P,
; ******
; STARY, ENTARY, Array declaration routines, were moved to ARRAY code
; ****** 11/24/70
MOVEM A,PARRIG(B) ;PUT DOWN THE ANSWER
DSCR TCON, BTRU, BFAL, BNUL, BINF
PRO TCON
DES kludges to make TRUE, FALSE, NULL, and ∞ work right
TRUE≡-1, so a constant is created (once), and Semantics rtnd
FALSE≡0
NULL≡""
∞≡LENGTH(innermost String being SUBSCRd -- else error)
⊗
↑TCON: JRST .+1(B) ;CALL CORRECT ROUTINE.
JRST BINF ;∞ OPERATOR.
JRST BNUL ;NULL
↑BTRU: SKIPA C,[XWD -1,TRULOC]
↑BFAL: MOVEI C,FALLOC
PUSHJ P,GETITC ;GET THE CONSTANT.
RETRT: MOVEM PNT,GENRIG
POPJ P,
↑BTRU1: HRROI C,TRULOC ;FOR TRUE
GETITC: SKIPE PNT,(C) ;IS THERE A VALUE ALREADY??
POPJ P, ;YES -- RETURN IT.
PUSH P,BITS
HLRE A,C ;THIS IS 0 OR -1
PUSHJ P,CREINT
MOVEM PNT,(C)
POP P,BITS ;RESTORE
POPJ P,
↑BNUL: SKIPE PNT,NULLOC
JRST RETRT
PUSH P,BITS
PUSH P,PNAME
PUSH P,PNAME+1
SETZM PNAME+1
SETZM PNAME
PUSHJ P,STRINS
MOVEM PNT,NULLOC
POP P,PNAME+1
POP P,PNAME
POP P,BITS
JRST RETRT
↑BINF: SKIPN LENCNT ;ARE WE INSIDEA SUBSTRING OPERATION??
ERR (<∞ (INF) INVALID, 0 ASSUMED>,1,BFAL)
HLRZ A,LENSTR ;LEFT HALF POINTS TO TOP OF QPUSH STACK.
SKIPGE A,(A) ;NEG IF INF. WITHIN SUBLIST SELECTOR
JRST LINF ;LIST INFIN. LOCATED IN LEAP
MOVEM A,GENLEF+1 ;SET UP FOR LENGTH
JRST LLEN1 ;MODIFIED FORM OF LENGTH.
DSCR TWID10, ECHK, ESET
PRO TWID10, ECHK, ESET
DES The "TWIDDLERS" which craftily manipulate the semantics
stack entries. They are used to move things around when
no other generators need be called, or when convenience warrents.
⊗
↑TWID10: MOVE A,GENLEF+1 ;THIS MOVES FROM ENTRY 1
MOVEM A,GENRIG ;TO ENTRY 0.
POPJ P, ;EXAMPLE -- PRODUCTION "XID"
;NOW FOR THE GENERALIZED EXPRESSION CHECKER. PASSED IS AN INDEX....
↑ECHK: JRST @.+1(B) ;GO DO RIGHT THINGS.
JRST CPOPJ ;REGULAR ARITH EXPRESSION.
JRST LEVBOL ;BOOLEAN EXPRESSION .. CONVERT TO INTEGER.
JRST LEAVE ;ASSOCIATIVE EXPR. -- CONVERT TO ITEM ..
; SAVE CLASS INDEX FOR PRODUCTIONS WHICH REFER TO TWO (FIRST)
↑ESET: MOVEM B,THISE ;SAVE INDEX IF THIS CLASS
POPJ P, ;HARDLY WORTH THE CALL
; (SHOULD HAVE WRITTEN?)
DSCR FDO1, FDO2
PRO FDO1 FDO2
DES LEAP function calling routines -- dipatch on class
to proper LEAP routine.
⊗
↑FDO1: JRST @.+1(B)
JRST ISTRIP ;ISTRIPLE
JRST SLOP ;STRING LOP
JRST ECVN ;CVN
JRST [SKIPN PNT,GENLEF+1
JRST STCNT
MOVE TBITS,$TBITS(PNT)
TRNN TBITS,STRING!INTEGR
JRST STCNT ;LENGTH OF SET.
JRST LLEN ;STRING LENGTH
]
REPEAT 2 ,<JRST BYPE> ;BYTE POINTER THINGS.
↑FDO2: JRST @.+1(B)
SELET
SELET
SELET ;FIRST,SECOND,THIRD
STUNT ;COP
ECVI ;CVI
SUBTTL EXECS for Handling Block Levels, Entering Variables
DSCR DWN, BLOCK, BLNAME, ENTID, UP, NAMCHK, etc.
PRO DWNA DWN BLOCK BLNAME ENTID ENDDEC UP1 UP2 NAMCHK UPWOM
DES These EXECS handle the declarations of a Block, from
recursion of lexical state at BEGIN and END, to the actual
entry of locals, to the checking of Block names.
SEE comments following this DSCR for more information.
⊗
Comment ⊗
These are the routines to process the entering and leaving of lexical levels.
DWN is called when a BEGIN is seen. It merely clears the boards in case
some declarations come along.
BLOCK is called if it develops that this block is going to have declarations.
The lexical level is incremented, and a new hash bucket is made.
The block entry in the semantic stack is flagged as "declarations
done in this block".
BLNAME is called if the block is going to have a name. This is independent
of whether it has declarations or not. If there are no declarations,
this is merely the name of a compound block.
ENTID is called to enter identifiers in the block. It basically calls
ENTERS. But there is a lot of bookkeeping to do -- allocate
item numbers, flag the block if arrays are declared, etc.
ENDDEC is called when all declarations are done. This puts out an
ARMRK if arrays were declared, etc.
UP1 or UP2 is called when the block is exited.
The block header is placed in a "block list" which is scanned
at allocation time (end of procedure). Symbols, etc. are
put out at that time.
NAMCHK is called to check to see if the respective BEGIN END pairs have
corresponding names.
PACDO is called to protect acs for the duration of the block
⊗
;COME HERE WHEN YOU SEE A BEGIN
↑DWN: SETOM NODFSW ; SET FLAG TO DEFER PROCESSING OF DEFINES
; UNTIL A BLOCK HAS BEEN EXECUTED.
↑DWN1: SETZM BITS ;IN CASE A CONSTANT WAS ENTERED
SETZM GENRIG+1
;WHILE WE WERE AWAY!!!
POPJ P, ;ALL DONE
↑OFFDEF: SETZM NODFSW ; TURN OFF FLAG WHICH DEFERS THE PROCESSING
POPJ P, ; OF DEFINES UNTIL A BLOCK HAS BEEN
; EXECUTED.
↑BLOCK: SETZM NODFSW ; TURN OFF FLAG WHICH CAUSES THE DEFERMENT
; OF DEFINE PROCESSING.
AOS LEVEL
MOVE A,VARB ;SAVE OLD CONTENTS.
SETZM VARB ;RESTART VARB.
SKIPN LPSA,GENLEF+1 ;"BLOCK" BLOCK THERE?
GETBLK ; NO -- GET ONE.
SKIPN QQFLAG ;IS THIS THE FIRST BLOCK WITH DECL'S?
HRRZM LPSA,QQBLK ;YES, STORE IT FOR UNDEC
SETOM QQFLAG
;**** QQFLAG WILL HAVE TO BE INCLUDED IN THE INITIALZATION CODE EVENTUALLY****
YESBB:
HRROM LPSA,GENRIG+1 ;FLAG THAT DELCARATIONS HAVE BEEN DONE.
PUSHJ P,RNGVRB ;PUT ON THE VARB RING
HRL A,TTOP ;GET OLD TTOP
MOVEM A,$ADR(LPSA) ;SAVE TTOP,,VARB.
MOVEW (<$SBITS(LPSA)>,LEVEL) ;SAVE CURRENT LEVEL
HRRM LPSA,TTOP ;NEW ONE
HRRZ TEMP,NMLVL ;PICK IT UP HERE IN CASE BLNAME DOESN'T
HRRM TEMP,$VAL2(LPSA) ;AND STORE IT IN DDT LEVEL LOCATION
PUSHJ P,MAKBUK ;MAKE A NEW SYMBOL BCKET
MOVE LPSA,SYMTAB ; GET NEW BUCKET
MOVE TEMP,GENRIG+1 ; GET THE BLOCK
HRRM LPSA,%TBUCK(TEMP) ; STORE BUCKET FOR LATER HASH OF IDENTS
JRST SHASH ;HASH AGAIN GIVEN THE NEW BUCKET
↑CSNAME: TLO FF,FFTEMP ;NAMED CASE STATEMENT
SETZM BITS ;DUPLICATE INITIAL CODE
MOVE PNT,GENLEF ; BECAUSE
MOVE LPSA,GENLEF+1 ; WE ALREADY HAVE A CASE BLOCK
JRST FOXX ; LINK IT TO STRING RING AND CONTINUE
↑BLNAME: TLZ FF,FFTEMP ;NAMED BLOCK,CPD STMT
SETZM BITS
MOVE PNT,GENLEF ;POINTER TO NAME CONSTANT.
GETBLK <GENRIG> ;GET A BLOCK.
FOXX: PUSHJ P,RNGSTR ;PUT ON THE STRING RING
TLNE FF,FFTEMP ;CASE STMT?
JRST CSVER ;YES, NO LABEL ISSUED
AOS TEMP,NMLVL ;DDT (BLOCK NAME) LEVEL
HRL TEMP,PCNT ;LOCATION OF FIRST WORD
MOVEM TEMP,$VAL2(LPSA) ;STORE IN BLOCK BLOCK
CSVER: MOVEI A,$PNAME-1(LPSA)
PUSH A,$PNAME(PNT) ;RECORD NAME.
PUSH A,$PNAME+1(PNT)
TLNN FF,CREFSW ;CREFFING?
JRST NOCRW ;NO
MOVEI A,15
PUSHJ P,CREFOUT ;BLOCK NAME COMING.
PUSHJ P,CREFASC ;AND CREF THE ASCII NAME OF BLOCK.
NOCRW:
TLNN FF,FFTEMP ;CASE?
TLNN FF,TOPLEV ;AT TOP LEVEL?
POPJ P, ;NO
MOVEI LPSA,IPROC+$PNAME-1 ;PUT IN PROGRAM NMAE.
PUSH LPSA,$PNAME(PNT)
PUSH LPSA,$PNAME+1(PNT)
JRST MAKT ;MAKE A NEW PROGRAM HEADER.
↑PACDO: MOVE LPSA,GENLEF+1 ;PICK UP AC NO TO SAVE
MOVE D,$VAL(LPSA) ;
CAIL D,0
CAILE D,17
ERR <ATTEMPT TO PROTECT A NUMBER NOT AN AC>,7
ANDI D,17 ;IN CASE THE FOOL CONTINUES
SKIPL B,ACKTAB(D)
JRST .+3
MOVE D,D ;FOR ERR UUO
ERR <ATTEMPT TO PROTECT SOMETHING ALREADY PROTECTED>,7
PUSHJ P,STORZ ;CLEAR THE AC
HRROS ACKTAB(D) ;PROTECT IT
HRLZI A,1
LSH A,-1(D) ;ORING MASK
MOVE LPSA,TTOP
ORM A,$TBITS(LPSA) ;MARK BLOCK SEMBLK
MOVEI A,12
MOVEI B,4
CNT1FA: SKIPL ACKTAB(A)
SOJLE B,ENGHAC
SOJGE A,CNT1FA
ERR <NOT ENOUGH ACS LEFT UNPROTECTED>,1
ENGHAC: POPJ P,
↑ENTID:
ORDENT:
SKIPN PNT,NEWSYM
JRST ENWAY ;NOT DEFINED BEFORE
MOVE TBITS,$TBITS(PNT) ;GET CURRENT SEMANTICS
TLNE TBITS,CNST ;DON'T LET CONSTANTS THROUGH
ERR <DECLARING A CONSTANT -- CHECK MACROS>,1
TLNN FF,CREFSW ;ARE WE CREFFING?
JRST ENWAY ; NO
MOVEI A,7 ;DELETE PREVIOUS ENTRY.
PUSHJ P,CREFOUT
ENWAY:
GLOC <
SKIPN ALLGLO ;GLOBAL LEAP ONLY?
JRST ENWAY2 ;NO
MOVE A,BITS
TRNE A,ITEM ;ONLY ITEMS ARE AFFECTED
TRO A,GLOBL
MOVEM A,BITS
ENWAY2:
>;GLOC
PUSHJ P,ENTERS ;DO THIS FIRST!!
MOVE LPSA,NEWSYM
PUSHJ P,GETADL ;GET GOOD BITS
TLNE FF,PRODEF ;ARE WE SCANNING ID LIST
JRST IDLIS ; YES
MOVE A,[XWD SAFE,SET+INTEGR] ;CHECK ON KILL SET GUY
TDC A,TBITS
TDNE A,[XWD SAFE,SET+INTEGR] ;IS IT ??
JRST EN.W1 ;NO
TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED]
ERR <ILLEGAL DATA TYPE COMBINATION FOR KILL SET>
EN.W1: TLNE TBITS,SBSCRP ;IF STRING ARRAYS, TURN
TRZ TBITS,STRING ;OFF THE STRING PART.
TRNE TBITS,ITEM!ITMVAR ;IGNORE DATUM TYPE OF ITEMS
TRZ TBITS,STRING!BOOLEAN!INTEGR!SET!LSTBIT!FLOTNG
MOVE PNT2,TTOP ;CURRENT BLOCK.
TLNE TBITS,OWN ;IF OWN, THEN DONTSAVE BIT
JRST IORDON ;
SKIPN SIMPSW ;BETTER NOT LET SIMPLE DO ALLOC
JRST .+3 ;HE ISNT SIMPLE
TDNE TBITS,[XWD SBSCRP,SET] ;CHECK FOR BAD GUYS
ERR <SIMPLE PROCEDURES MAY NOT ALLOCATE!>,1,IORDON
IORM TBITS,$VAL(PNT2) ;THE "OR" OF ALL SYMBOLS DEFINED.
IORDON:
GLOC <
TRNN TBITS,ITEM ;IF ITEM OR
TRNN TBITS,GLOBL ;NOT GLOBAL, THEN GO ON
JRST NOGLB
TLNE FF,TOPLEV ;IF NOT AT TOP LEVEL
TRNE TBITS,STRING!LABEL ;OR IF THESE RIDICULUOUS TYPES.
ERR <INVALID GLOBAL TYPE>,1
AOS A,GLOBCNT ;COUNT OF GLOBALS.
CAILE A,GLBAR ;WITHIN BOUNDS OF GLOBAL AREA?
ERR <TOO MUCH GLOBAL DATA>,1
HRLM A,$VAL2(PNT) ;AND SAVE.
NOGLB:
>;GLOC
; FOLLOWING REMOVED TO ALLOW INTRODUCTION OF STRING ITEMS.
; TRNN TBITS,LPARRAY
; JRST [TRNN TBITS,STRING
; JRST .+1
; TRNE TBITS,ITEM!ITMVAR
; ERR <STRING ITEMS NOT IN, ALTHOUGH STRING ARRAY ITEMS ARE>,1
; JRST .+1]
NOGRUMP:
TRNE TBITS,ITEM!ITMVAR!SET ;A LEAP DATA TYPE?
SETOM LEAPIS ;TELL WORLD SOMEONE USED LEAP.
TRNN TBITS,ITEM ;WAS IT AN ITEM?
POPJ P,
PUSH P,PNT ;SAVE ITEM SYMBOL POINTER
PUSH P,BITS
GLOC <
TRNE TBITS,GLOBL ;IF A GLOBAL ITEM, THEN MAKE LEFT HALF
SOSA A,GITEMNO
>;GLOC
;; %AG% LH(ITEMNO) NOW CONTAINS ITEM_START
AOS A,ITEMNO ;MAKE A NEW NUMBER FOR IT
HRRZS A
;; %AG%
AOS ITMCNT ;TOTAL NUMBER OF DECLARED ITEMS
PUSHJ P,CREINT ;MAKE AN INEGER OF ITEM NUMBER.
MOVE PNT2,PNT
PUSH P,A ;SAVE ITEM NUMBER
SKIPN PNMSW ;PNAMES GOING NOW ?
JRST NOPNM ;NO
AOS PNMSW ;INDEX COUNT.
PUSHJ P,STRINS ;MAKE ANOTHER COPY OF NAME
HRL PNT,A ;ITEM NUMBER.
QPUSH (PNLST,PNT) ;SAVE FOR LATER.
NOPNM:
MOVE A,-1(P) ;TYPE BITS
PUSHJ P,ITMTYP ;GET TYPE INDEX
HRL A,(P) ;ALSO ITEM NUMBER
QPUSH (ITMSTK)
POP P,A ;RESTORE A
POP P,BITS
POP P,LPSA
;; #KW# DON'T ALLOW INTERNAL OR EXTERNAL ITEMS
MOVE TBITS,$TBITS(LPSA)
TLZE TBITS,EXTRNL!INTRNL ;ITEMS CAN'T BE INTERNAL OR EXTERNAL
ERR <ITEMS CAN'T BE INTERNAL OR EXTERNAL>,1
MOVEM TBITS,$TBITS(LPSA)
;; #KW#
MOVEM PNT2,$VAL2(LPSA) ;SAVE THE POINTER TO INTEGER!!!!
POPJ P, ;EVEN IF "GOGOL", ITEMS DON'T NEED LOCATIONS
IDLIS: TRNN TBITS,PROCED
TLNE TBITS,SBSCRP
JRST [TLZE TBITS,VALUE
ERR <VALUE PROCEDURE OR ARRAY CALLS NOT IMPLEMENTED>,1
TLO TBITS,REFRNC
TRZ TBITS,INPROG ;ONLY RELEVANT TO PROCED
JRST IDFXN]
TLNN TBITS,REFRNC
TLO TBITS,VALUE ;IMPLIED VALUE
IDFXN: TRNE TBITS,PROCED
TLO TBITS,ANYTYP
MOVEM TBITS,$TBITS(PNT)
;;#HR# 6-14-72 JRL HANDLE STRING ITEMVAR FORMAL PARAMETERS
TRNE TBITS,ITEM!ITMVAR ;IGNORE STRING BIT IF ITEM
TRZ TBITS,STRING
;;#HR#
TRNE TBITS,STRING ;UPDATE THE STACK
TLNE TBITS,REFRNC ;COUNTERS ACCORDING
AOSA APARNO ;TO THE TYPE OF PARAMETER
AOS SPARNO
POPJ P,
↑ENDDEC:PUSHJ P,ENDJMP ;FIX UP JUMP AROUND PROCS, IF ANY
JFCL ;IGNORE SKIPPEDNESS
SKIPN LPSA,GENLEF+1 ;DID WE DEFINE ANYTHING?
POPJ P, ;NO -- RETURN
HRRZ TEMP,PCNT ;UPDATE LOC OF FIRST WORD OF BLOCK
HRLM TEMP,$VAL2(LPSA)
ENDDE: TLZ FF,TOPLEV
POPJ P, ;ALL DONE
↑↑ENDJMP:
MOVE TEMP,TPROC ;SURROUNDING PROCEDURE SEMANTICS
HLRZ TEMP,%TLINK(TEMP) ;2D PROC BLOCK
SKIPN B,$SBITS(TEMP) ;DID ANYBODY JUMP? (SEE PRDEC)
JRST CPOPJ1 ; NOBODY DID
SETZM $SBITS(TEMP) ;CLEAR FOR NEXT TIME
HRL B,PCNT
JRST FBOSWP ;NOW FIX UP JUMP AND QUIT
↑CPOPJ1:AOS (P) ;THE CANONICAL SKIP-RETURN
POPJ P, ;DONE
;HERE WHEN YOU SEE THE MATCHING "END"
↑UP1: SKIPA PNT,GENLEF+1 ;FOR CODE_BEGIN SEQUENCES
↑UP2: MOVE PNT,GENLEF+2 ;BEGIN SEMANTICS.
UPPP: MOVEM PNT,GENRIG ;SAVE FOR NAME CHECKING.
JUMPE PNT,NMSUB ;NO BLOCK ASSOCIATED WITH THIS BEGIN
JUMPL PNT,UPCHK ;THIS BLOCK HAS DECLARATIONS ...
SKIPN $PNAME(PNT) ;NAMED COMPOUND STATEMENT?
JRST NONM ; NO, FORGET IT
HRRZS PNT ;LH 0 TO INDICATE PRESENCE OF NAME
QPUSH (BLKIDX,PNT) ;PUT CPD STMT SEMBLK IN STACK
SETZM %RVARB(PNT) ;MAKE SURE THERE'S NO LIST
SOS NMLVL ;LOWER DDT LEVEL BY ONE
CREFWQ:
TLNN FF,CREFSW ;CREFFING ?
POPJ P, ;DON'T DELETE THE BLOCK
MOVEI LPSA,(PNT) ; POINTER TO BLOCK.
JRST CREFBLOCK ;AND CREF BLOCK EXIT.
NONM: MOVE LPSA,PNT
PUSHJ P,URGSTR ;IN CASE IT WAS A NAMED BLOCK..!!
FREBLK <PNT>
NMSUB: POPJ P,
UPCHK: PUSHJ P,GOSTO ;STORE EVERYONE
MOVE TBITS,$VAL(PNT)
;;#KT# ↓ TYPO AS TO WHERE KILL SET IS
HRRZ C,$ACNO(PNT) ;IF WE HAVE A KILL LIST
JUMPN C,DBEX ;MUST BEXIT
LDB C,[POINT LLFLDL,$SBITS(PNT),35] ;PICK UP LEXIC LEVEL
CAIE C,1 ; IF NOT GLOBAL AND
TDNN TBITS,[ XWD SBSCRP,SET] ;IF ONE OF THE BAD GUYS
JRST EMJR ;THINGS ARENT SO EASY
;;#KX# 1-9-73 DO ALLSTO BEFORE YOU BEXIT -- RHT
DBEX: PUSHJ P,ALLSTO ;
HRR C,PCNT
HLL C,$SBITS(PNT)
HRLM C,$SBITS(PNT) ;FIXUP BK LVI REF
EMIT <MOVEI LPSA,NOUSAC!USADDR>
XCALL <BEXIT>
EMJR: HRROS PNT ;ASSUME NO NAME
SKIPE $PNAME(PNT)
JRST [HRRZS PNT ;WRONG AGAIN
SOS NMLVL ;NAME LEVEL
PUSHJ P,CREFWQ ;POSSIBLY CREF BLOCK EXIT.
JRST .+1]
HLRZ A,$TBITS(PNT) ;BITS OF PROTECTED ACS
COMMENT ⊗ HORRIBLE LOOP TO UNDO PROTECTION OF ACS IN THIS BLOCK ⊗
PUSH P,B
PUSH P,D
MOVEI D,11
MOVEI B,1000 ;BIT FOR AC 11
UPACHK: TDZE A,B ;DID WE PROTECT IT
HRRZS ACKTAB(D) ;UNPROTECT IT
LSH B,-1
SOJGE D,UPACHK ;
POP P,D
POP P,B
;**************************************
QPUSH(BLKIDX,PNT)
MOVE A,$ADR(PNT)
HLRM A,TTOP ;RESTORE IT.
HRRM A,VARB ;RESTORE THE VARB POINTER.
SOS LEVEL
JRST FREBUK ;come up a level in symbol buckets.
; Check for match on block names.
↑NAMCHK: SKIPN PNT,GENLEF+1 ;BLOCK SEMANTICS.
JRST NMCHKK
MOVE PNT2,GENLEF ;END NAMED.
MOVE A,$PNAME+1(PNT) ;BYTE POINTER.
JUMPE A,NMCHKK ;BLOCK UNNAMED
CAMN A,$PNAME+1(PNT2) ;AND THE OTHER
POPJ P,
JRST MTCERR ;NO GOOD
NMCHKK: MOVE TEMP,TPROC ;TRY FOR MATCH WITH
MOVE PNT2,GENLEF ;END NAMED
MOVE A,@$PNAME+1(TEMP) ;CURRENT PROC NAME
CAMN A,@$PNAME+1(PNT2) ; (FIRST WORD MATCH ONLY)
POPJ P,
SKIPN PNT
ERR <NAME AFTER UNNAMED BLOCK!>,1,CPOPJ
MTCERR: ERR <NAMES OF BEGIN AND END DO NOT MATCH>,1
POPJ P,
SUBTTL EXECS for REQUIRE Verb
DSCR RQ00, RQSET, SRCSWT
PRO RQ00 RQSET SRCSWT REQERR
DES These routines handle the REQUIRE Syntax of the forms:
| | PNAMES
| | SYSTEM_PDL
| | STRING_PDL
| n | STRING_SPACE
| | ARRAY_PDL
| | NEW_ITEMS
| | VERSION
REQUIRE |-----------------------|
| | LIBRARY
| | LOAD_MODULE
| "file description" | SEGMENT_FILE
| | SEGMENT_NAME
| | SOURCE_FILE
|-----------------------|
| "2 or 4 characters" | DELIMITERS
|-----------------------|
| "some characters" | ERROR_MODES
PNAMES and SOURCE_FILE are handled specially
⊗
↑RQ00: SETZM SCNVAL ;IN CASE NO NUMBER IS GIVEN.
ZPOPJ: POPJ P,
↑RQSET:
SETZM BITS ;IN CASE UNARY WAS CALLED
JUMPE B,PNAM ;PNAMES......
MOVE A,SCNVAL ;THE CONSTANT
XCT RQTAB-1(B) ;DO SOMETHING
POPJ P,
RECORD: HRRZ TEMP,SPCTBL ;THE SPACE RESERVATIN TABLE
ADDI TEMP,1 ;ONE MORE WORD
HRRM TEMP,SPCTBL ;HOPEFULLY
CAIN TEMP,=18 ;OVERFLOW?
ERR <TOO MANY SPACE REQUIRES>,1
CAILE TEMP,=17 ;PREVIOUS OVERFLOW?
POPJ P, ;YES
HRL A,B ;THE INDEX INDICATES WHICH
TLO A,STDSPC ; SPACE IS REQUESTED
MOVEM A,SPCTBL+1(TEMP) ;INTO LOADER BLOCK FOR LATER OUTPUT
POPJ P,
RQTAB: JRST RECORD ;SYSTEM PDL
JRST RECORD ;STRING PDL
JRST RECORD ;STRING SPACE
JFCL ;ARRAY PDL NO LONGER EXISTS
HRRM A,NWITM ;NEW ITEMS, RH SINCE BUCKETS WILL USE LH
MOVEM A,VERNO ;VERSION NUMBER
JRST LBSET ;LIBRARY REQUEST
JRST PRGSET ;LOAD MODULE REQUEST.
JRST REQERR ;SOMETHING WRONG WITH SOURCE_FILE RQST
JRST DELSTG ; PROCESS REQUIRE DELIMITERS COMMAND
JRST REPDEL ; PROCESS REPPLACE DELIMITERS COMMAND
JRST POPDEL ; PROCESS POP_DELIMITERS COMMAND
JRST NULDEL ; PROCESS NULL_DELIMITERS COMMAND
SETOM ALLGLO ; COMPILE FOR GLOBAL LEAP ONLY
GLOC < ;REQUESTS FOR SEGMENT NAMES, ETC.
JRST SEGSET ;LOGICAL SEGMENT NAME REQUEST
JRST SEGFL ;SEGMENT FILE NAME REQUEST
>;GLOC
JRST INMAIN ;GO INITIALIZE MAINPR
JRST REQPLL ; POLLING INTERVAL
JRST LPBUCK ; REQUIRE n BUCKETS
JRST ITMSTRT ;ITEM START
JRST MODSET ;ERROR MODES
LBSET: SKIPA B,[LBTAB] ;LIBRARY OUTPUT BLOCK ADDR
PRGSET: MOVEI B,PRGTAB ;PROGRAM OUTPUT BLOCK ADDR
GETSEM (1) ;SEMANTICS OF STRING CONST
HRROI TEMP,$PNAME+1(PNT)
POP TEMP,PNAME+1
POP TEMP,PNAME ;SET UP FOR CALL
JRST PRGOUT ;OUTPUT REQUEST, RETURN
GLOC <
SEGSET: PUSHJ P,GETSOM ;GET NAME, SET UP TABLE POINTER
MOVEM C,SEGNAM ;NAME ONLY, PUT IN SPACE BLOCK
POPJ P,
SEGFL: PUSHJ P,GETSOM
JUMPN A,.+2 ;DEVICE
MOVSI A,(<SIXBIT /DSK/>) ;DEFAULT
MOVEM A,SEGDEV ;DEVICE NAME
MOVEM C,SEGFIL ;FILE NAME
MOVEM D,SEGPPN ;WHEEE (TRANSLATION -- PPN)
POPJ P,
GETSOM: GETSEM (1) ;→STRING REPRESENTING REQUEST
HRROI TEMP,$PNAME+1(PNT) ;PNAME
POP TEMP,PNAME+1
POP TEMP,PNAME
JRST FILSCN ;CONVERT TO SIXBIT IN A,C,D
>;GLOC
DELSTG: GETSEM (1) ; GET POINTER TO STRING SEMBLK
TLNE TBITS,CNST ; CONSTANT?
TRNN TBITS,STRING ; STRING?
ERR <NOT A STRING CONSTANT - STATEMENT IGNORED>,1,CPOPJ ;
↑GETDEL: HRRZ LPSA,$PNAME(PNT) ; GET STRING CHARACTER COUNT
JUMPE LPSA,NULDEL ; NULL DELIMITER STRING?
MOVE PNT,$PNAME+1(PNT)
QPUSH (DELSTK,<(PNT)>) ; SAVE THE DELIMITERS
GETDL1: SETOM REQDLM
MOVE TEMP,[XWD -DELNUM,0] ; FOR AOBJN
↑GETDL2:SOJGE LPSA,.+2 ; DELIMITER SCANNER LOOP
ERR <NOT ENOUGH DELIMITERS IN INPUT - GARBAGE IN REST> ;
ILDB B,PNT ; GET NEXT DELIMITER
SKIPG SCNTBL(B) ; SPECIAL OR IGNORABLE?
JRST GETDL2 ; YES, GET NEXT
SKIPN SWBODY ; SPECIAL DELIMITER DEFINITION?
MOVEM B,LOCMBD(TEMP) ; NO, STORE FOR PERMANENT REFERENCE
MOVEM B,CURMBG(TEMP) ; STORE FOR TEMPORARY REFERENCE
AOBJN TEMP,GETDL2 ; CHECK IF DONE
POPJ P, ; YES
REPDEL: QPOP (DELSTK)
JRST DELSTG
POPDEL: QPOP (DELSTK)
QLOOK(DELSTK) ; GET A POINTER TO TOP ELEMENT OF DELSTK
SETZM REQDLM
SKIPN (A)
POPJ P,
HRLI A,(<POINT 7,0>)
MOVE PNT,A
MOVEI LPSA,DELNUM
JRST GETDL1
NULDEL: SETZM REQDLM
QPUSH (DELSTK,REQDLM)
POPJ P,
↑MKNSTB: MOVEI C,1 ; INITIALIZE COUNT FOR NESTABLE CHARS.
MOVEI A,NUMCHA ; NUMBER OF CHARACTERS
CONCNV: SOJL A,CPOPJ ; DONE?
MOVE B,SCNTBL(A) ; LOAD AND TEST IF NESTABLE CHARACTER
TLNN B,NEST ;
JRST CONCNV ; NO, GET NEXT CHAR
MOVEM C,NSTABL(A) ; YES, NSTABL CONTAINS INDEX AMOUNT
; TO BE ADDED TO LOCNST
TLNE B,LNEST ; DONE WITH A NESTED PAIR?
ADDI C,1 ; YES, INCREMENT COUNTER
JRST CONCNV ; GET NEXT
LPBUCK: ; FOR REQUIRE n BUCKETS
JUMPGE A,.+2
MOVEI A,0 ; MAKE SURE IS POSITIVE
JFFO A,.+2 ; FIND FIRST ONE
JRST MINBKT ; MINIMUM NUMBER OF BUCKETS IS 2
HRLZI C,400000 ; A BIT FOR TESTING
MOVN B,B
LSH C,(B) ; C NOW IS THE LARGEST POWER OF TWO
; SUCH THAT C ≤ n
CAME A,C ; SEE IF n WAS A POWER OF TWO
LSH C,1 ; NO, GO TO NEXT HIGHER POWER.
HAVSIZ: HRLM C,NWITM
POPJ P,
MINBKT: MOVEI C,2
JRST HAVSIZ
MODSET: PUSH P,FF ;SAVE FF
HLLZ FF,%ERFLGS ;GET MODES
MOVE A,GENLEF+1 ;GET STRING CONSTANT
SKIPN B,$PNAME(A) ;STRING LENGTH
POPJ P,
MOVE A,$PNAME+1(A) ;THE STRING
HRRZ B,B
REP..: SOJGE B,UNNCDE
POP P,FF
POPJ P,
UNNCDE: ILDB C,A ;FIRST LETTER
CAIN C,"-"
JRST [SETCA FF, ;LITTLE TRICKERY HERE
ILDB C,A
JRST .+1]
CAIL C,133 ;UPPER CASE?
SUBI C,40
CAIN C,"A"
TLO FF,AUTO+MINUS ;MINUS SIGNALS THAT WE CAUGHT SOMETHING
CAIN C,"Q"
TLO FF,QUIET+MINUS
CAIN C,"K"
TLO FF,KEEP+MINUS
CAIN C,"N"
TLO FF,NUMBS+MINUS
CAIN C,"L"
JRST [TLO FF,LOGGIN+MINUS
SKIPN TEMP,SRCFIL
MOVE TEMP,[SIXBIT /ERRORS/]
MOVEM TEMP,%ERFIL
MOVE TEMP,[SIXBIT/LOG /]
HLLZM TEMP,%ERFIL+1
JRST .+1]
TLNN FF,MINUS ;CATCH ANYTHING?
JRST [ERR <REQUIRE ERROR_MODES RECOGNIZES ONLY A,Q,K,N,L OR ->,1
MOVE FF,%ERFLGS
JRST REP..]
TRNE FF,-1
SETCA FF,
TLZ FF,MINUS
HLLM FF,%ERFLGS
JRST REP..
↑SRCSWT:
; FIRST CHECK VALIDITY OF SOURCE_FILE SWITCHING RQST, SET SPECIAL SWITCHER
MOVE TBITS2,SCNWRD
TLNE TBITS2,MACIN ;IF IN MACRO, ILLEGAL
ERR <DON'T SWITCH SOURCE FILES INSIDE MACRO>,1,SCANNER
SETOM SRCDLY ;FLAG SCANNER
POPJ P,
; NOW TRY THE SWITCH-OVER
; CHECK IF THE FILE WAS ACTUALLY SWITCHED
↑SRCCHK: SKIPE SRCDLY ;WILL BE ZERO IF SWITCHED
ERR <SOURCE FILE REQUEST MUST END LINE>
POPJ P,
↑REQERR: ERR <INVALID SYNTAX -- SOURCE FILE REQUEST>,1
POPJ P,
EXTERNAL OUTSTR
↑TYPMSG: MOVE USER,GOGTAB;
MOVE SP,SPDL(USER)
MOVE PNT,GENLEF+1 ;STC SEMBLK TO BE TYPED;
PUSH SP,$PNAME(PNT)
PUSH SP,$PNAME+1(PNT)
PUSHJ P,OUTSTR ;WRITE IT OUT
JRST SCOMM1 ;ZAP STC BLOCK
SUBTTL EXECS for MACRO (DEFINE) Declarations
DSCR DFPREP, DCPREP, DWPREP, DFPINS, DFSET, DFENT, MACOFF, MACON
PRO DFPREP DCPREP, DWPREP, DFPINS DFSET DFENT MACOFF, MACON
DES Execs for syntax
DEFINE macnam(a1,a2..)="macro body", macnam2=....,...;
Relies heavily on mechanisms built into the SCANNER to
parse the macro body, insert parameters.
SEE SCANNER
⊗
Comment *
DFR: @I ( → DPL EXEC DFPR1 SCAN 2 GO TO DPA
@I SG → DPL SG EXEC DFPREP GO TO LEQ OR GO TO Q0
DFPREP -- prepare to define a macro body.
Enter DEFINE symbol. Use current def if
it's at the same level (done in ENTER). Get
a new symbol table bucket.
DCPREP -- prepare to define a conditional compilation CASEC body.
Check if first casec and if not then enter the computed
casec value in the $VAL2 entry of the semblk obtained for
the casec body.
DWPREP -- prepare to define a conditional compilation WHILEC, FORC,
or FORLC body. *
↑MACON: TLZ FF,NOMACR ; TURN MACRO EXPANSION ON
POPJ P, ; RETURN
↑EVMCOF: SKIPN EVLDEF ; TURN OFF MACRO EXPANSION ONLY IF
; EVALDEFINE IS NOT IN PROGRESS
↑MACOFF: TLO FF,NOMACR ;NO MACRO EXPANSIONS WHEN REDEFINING!
POPJ P,
↑DCPREP: GETBLK NEWSYM ; SEMBLK FOR CASEC BODY
GETSEM (1) ; SEMANTICS OF CASEC NUMBER
MOVE TEMP,$VAL(PNT) ; GET CASEC NUMBER
JUMPN TEMP,NOFRST ; TWIDDLE IF NOT FIRST CASEC
PUSHJ P,CPSHEN ; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG
SETOM SWCPRS ; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC
; TO BE EXECUTED)
JRST CMPRP2 ; DON'T TWIDDLE SINCE FIRST CASEC
NOFRST: MOVEM TEMP,$VAL2(LPSA) ; STORE CASEC NUMBER IN $VAL2 OF THE SEMBLK
MOVEM LPSA,GENRIG+1 ; SAVE SEMANTICS OF PSEUDO MACRO BODY SEMBLK
MOVE TEMP,%CFLS1 ; TWIDDLE
MOVEM TEMP,PARRIG ; NOT THE FIRST CASEC
JRST DWPRP1 ; REST OF MACRO BODY PRELIMINARIES
↑DWPREP: GETBLK NEWSYM ; SEMBLK FOR WHILEC, FORC, OR FORLC BODY
DWPRP1: HRLZI TEMP,DEFINE ; GET GOOD BITS
MOVEM TEMP,$TBITS(LPSA) ; SET SEMBLK DESCRIPTOR
HRRZS %TLINK(LPSA) ; ZERO THE MACRO BODY DEFINITION LINK
JRST CMPRP2 ; REST OF MACRO BODY PRELIMINARIES
↑DFPREP: HRLZI TEMP,DEFINE ; GET GOOD BITS
MOVEM TEMP,BITS ; PREPARE TO DO AN ENTERS
PUSHJ P,ENTERS ; ENTER MACRO NAME IF NOT ALREADY DEFINED
MOVE LPSA,VARB ; CHECK IF DEFINE IS HAPPENING BEFORE THE
SKIPN LEVEL ; OUTER LEVEL BLOCK HAS BEEN STARTED. IF
MOVEI LPSA,RESYM ; YES, THEN SET VARB TO RESYM SO DONES WILL
MOVEM LPSA,VARB ; WORK PROPERLY.
CMPRP2: PUSHJ P,MAKBUK ;DOWN ONE LEVEL FOR PARAMETERS
AOS LEVEL
MOVE LPSA,NEWSYM ;SYMANTICS OF ENTRY
MOVEM LPSA,GENRIG ;MAY BE GARBAGING "="'S SEMANTICS
MOVE TEMP,VARB ;SAVE VARB LIST -- WILL LINK FORMALS
MOVEM TEMP,$ADR(LPSA) ; OLD VARB POINTER IS SAVED IN $ADR SO THAT
; THE MACRO BODY IS STILL KNOWN
SETZM VARB
HLLZS $VAL(LPSA) ;CLEAR #PARAMS COUNT (SAVE COUNT FOR PREV DEF).
SETZM $ACNO(LPSA) ;WILL POINT AT FIRST PARAM
TLZ FF,NOMACR ;MACROS EXPANDED AGAIN
POPJ P,
Comment ⊗
DPA: SG @I , → SG EXEC DFPINS SCAN 2 ¬DPA
SG @I ) → SG EXEC DFPINS SCAN ¬LEQ #Q0
Insert macro parameter:
1. Enter the symbol
2. Insert in list off %TLINK in macro name semantics ⊗
↑MDFPNS: TLZ FF,NOMACR ; MACROS EXPANDED AGAIN WHEN THROUGH SCANNING
; FORMALS
↑DFPINS: HRLZI TEMP,FORMAL!DEFINE ;ENTER PARAM (LINK ON SPECIAL VARB RING)
MOVEM TEMP,BITS
PUSHJ P,ENTERS
MOVE TEMP,GENLEF+2 ;SEMANTICS FOR MACRO NAME
AOS A,$VAL(TEMP) ;COUNT MACRO PARAMS
MOVE LPSA,NEWSYM ;SEMANTICS OF THIS PARAM
SKIPN $ACNO(TEMP) ;IS THIS THE FIRST ONE?
MOVEM LPSA,$ACNO(TEMP) ; YES, STORE POINTER TO FIRST
HRRZM A,$VAL(LPSA) ;STORE PARAM NUMBER
POPJ P,
Comment ⊗
LEQ: STC → EXEC SPDMBD SCAN ¬LEQ1
Check if a special macro body delimiter declaration has occurred ⊗
↑SPDMBD: SKIPN REQDLM ; TRYING TO OVERRIDE NULL DELIMITER MODE?
SETOM RSTDLM ; YES, SET FLAGS SO CAN RESET PROPERLY WHEN DONE
SETOM REQDLM ;
SETOM SWBODY ; SET SWITCH DELIMITER DECLARATION FLAG
MOVE TEMP,[XWD -2,0] ; SET UP A COUNT
MOVE PNT,GENLEF ; GET SEMBLK ADDRESS OF STRING
HRRZ LPSA,$PNAME(PNT) ; GET READY FOR A SPECIAL DELIMITER MODE
MOVE PNT,$PNAME+1(PNT) ; SCAN
JRST GETDL2 ; GET SPECIAL DELIMITERS
Comment ⊗
LEQ1: = → EXEC DFSET SCAN 2 ¬DEQ #Q0
Get ready for macro body ⊗
↑DFSET: JRST FFPUSH ; SAVE DEFLUK BIT OF FF AND TURN IT ON IN FF
Comment ⊗
DEQ: DPL ICN , → EXEC DFINE SCAN 2 ¬DFR
DDEF DPL ICN ; → EXEC DFINE SCAN ¬DS0
SDEF DPL ICN ; → EXEC DFINE SCAN ¬S1 #Q0
Eradicate formal parameter ring, turn off special
string mode bit after macro scan -- install the macro body. ⊗
↑DFENT1: MOVE A,GENLEF+3 ; SEMBLK OF CASEC ENTRY
JRST NOREDF ; NO PARAMETER LIST TO DELETE
↑DFENT: MOVE A,GENLEF+2 ; GET SEMBLK ADDRESS
MOVE LPSA,$ACNO(A) ; FORMAL LIST
PUSHJ P,KILLST ; DELETE FORMAL PARAM LIST
SETZM $ACNO(A) ; NO MORE LIST
HRRZ TEMP,$VAL(A) ; #PARAMS FOR THIS (NEW) DEFINITION
HRLZM TEMP,$VAL(A) ; #PARAMS FOR CURRENTLY ACTIVE DEF.
HLRZ LPSA,%TLINK(A) ; CHECK IF THE MACRO HAS BEEN PREVIOUSLY
JUMPE LPSA,NOREDF ; DEFINED, AND IF YES DELETE THE PREVIOUS
PUSHJ P,REMOPL ; DEFINITION IF IT IS THE ONLY REFERENCE TO IT
NOREDF: MOVE TEMP,$ADR(A) ; RESTORE SAVED VARB POINTER
MOVEM TEMP,VARB ; (IT WAS USED TO KEEP FORMALS LOCATED)
MOVE LPSA,GENLEF+1 ; MACRO BODY (STRING CONST) SEMANTICS
MOVE TBITS,$TBITS(LPSA) ; GET GOOD BITS
TRNE TBITS,STRING ; TEST IF A STRING AND SET IT TO STRING
JRST NOCNST ; YES, NO NEED TO CONVERT CONSTANT TO STRING
PUSH P,$VAL(LPSA) ; PUSH VALUE
PUSHJ P,REMOPL ; DELETE SEMBLK OF NUMERIC CONSTANT IF POSSIBLE
EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
PUSHJ P,CVS ; CONVERT TO STRING
POP SP,PNAME+1 ; FIRST WORD OF STRING DESCRIPTOR
POP SP,PNAME ; SECOND WORD OF STRING DESCRIPTOR
EXCH SP,STPSAV ; RETURN STRING POINTER
MOVSS POVTAB+6 ; KEEP ERROR MESSAGES IN SYNCH
PUSHJ P,STRINS ; MAKE STRING CONSTANT
MOVEM PNT,GENLEF+1 ; RECORD RESULTS WHERE WILL BE SEEN
NOCNST: SOS LEVEL
PUSHJ P,FREBUK ;RETURN UP
JRST CLRSET ;CLEAR BITS
↑SWDLM: SKIPN SWBODY ; NEED TO SWAP MACRO BODY DELIMITERS?
POPJ P, ; NO, RETURN
SETZM SWBODY ; RESET SWITCH DELIMITER DECLARATION FLAG
SKIPN RSTDLM ; RESTORING NULL DELIMITERS MODE?
JRST .+4 ; NO
SETZM RSTDLM ; RESTORE THE APPROPRIATE FLAGS
SETZM REQDLM ;
POPJ P, ;
HRROI TEMP,LOCMBD+1 ; GET RESTORING ADDRESS
POP TEMP,CURMED ; RESTORE START DELIMITER
POP TEMP,CURMBG ; RESTORE END DELIMITER
POPJ P, ; RETURN
↑SETDLM: QPUSH(LOKDLM,DLMSTG) ; SAVE CURRENT DLMSTG VALUE
SKIPE REQDLM ; SPECIAL DELIMITER MODE?
SETOM DLMSTG ; YES, POSSIBLY LOOKING FOR DELIMITED STRING
POPJ P, ; RETURN
↑OFFDLM: QPOP(LOKDLM,DLMSTG) ; CEASE LOOKING FOR DELIMITED STRING
POPJ P, ; RETURN
↑ENDMAC: MOVE LPSA,GENLEF+1 ; GET MACRO BODY SEMBLK
EXCH SP,STPSAV ; GET STRING STACK POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSH SP,[XWD 0,2] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[BYTE (7) 177 0]] ; END OF MACRO STRING
PUSHJ P,CAT ; CONCATENATE
POP SP,PNAME+1 ; SECOND WORD OF STRING DESCRIPTOR
POP SP,PNAME ; FIRST WORD OF STRING DESCRIPTOR
PUSHJ P,STRINS ; ENTER MACRO BODY STRING IN SYMBOL TABLE
MOVE LPSA,GENLEF+2 ; LINK MACRO NAME TO MACRO BODY
HRLM PNT,%TLINK(LPSA) ;
EXCH SP,STPSAV ; RETURN STRING POINTER
MOVSS POVTAB+6 ; KEEP ERROR MESSAGES IN SYNCH
POPJ P, ; RETURN
↑SWPON: SETOM SWCPRS ; SWITCHING PARSERS IS ALLOWED
POPJ P, ; RETURN
DSCR STCAT
PRO STCAT
DES Converts a macro body to a string.
CVMS(macname). If called with a macro name and a parameter list, then
the parameters are ignored and a suitable error message is emitted.
⊗
↑STCAT: TLZ FF,NOMACR ; TURN MACRO EXPANSION BACK ON
;;#OS# 10-31-73 HJS CHECK FOR UNDECLARED MACRO NAME
SKIPE LPSA,GENLEF ; IS THIS A DECLARED MACRO?
JRST CVMSOK ; YES,
ERR <NOT A MACRO NAME SUPPLIED TO CVMS> ; NO, RETURN A NULL STRING
SETZM PNAME ;
SETZM PNAME+1 ;
JRST UNDCVM ;
CVMSOK: HLRZ LPSA,%TLINK(LPSA) ; CONVERT TO STRING AND ENTER IT IN THE
; SYMBOL TABLE IF NOT ALREADY THERE.
RM1770: MOVE TEMP,$PNAME(LPSA) ;
SUBI TEMP,2 ; THE ONLY DIFFERENCE BETWEEN THE
MOVEM TEMP,PNAME ; STRING AND THE MACRO BODY IS
MOVE TEMP,$PNAME+1(LPSA) ; THAT THE STRING DOES NOT HAVE
MOVEM TEMP,PNAME+1 ; 177-0 AT ITS END.
UNDCVM: PUSH P,BITS ;
PUSHJ P,STRINS ;
POP P,BITS ;
MOVEM PNT,GENRIG ; SET THE SEMANTIC STACK ENTRY TO
; THE SEMBLK ADDRESS OF THE STRING.
POPJ P, ;
DSCR CVPFRM, ASGOFF
PRO CVPFRM, ASGOFF
DES These routines are used to implement the CVPS construct which converts a macro
actual parameter to a string.
CVPS(formal parameter name).
CVPFRM This routine fetches the appropriate parameter from the VARB ring associated
with the cureent invocation of the macro and strips off the 177-0 at its end
and converts it to a string.
ASGOFF This routine turns off the flag which inhibits the expansion of macro actual
parameters in case an error has occurred.
⊗
↑CVPFRM: SETZM ASGFLG ; TURN OFF ACTUAL MACRO PARAMETER EXPANSION
MOVE B,GENLEF ; INHIBITION FLAG AND GET SEMBLK OF ACTUAL
MOVE LPSA,DEFRNG ; PARAMETER TO BE CONVERTED TO A STRING
GETITP: SOJE B,RM1770 ;
RIGHT ,%RVARB, ;
JRST GETITP ;
↑ASGOFF: SETZM ASGFLG ; TURN OFF ACTUAL MACRO PARAMETER EXPANSION
POPJ P, ; INHIBITION FLAG
DSCR SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT
PRO SPRZER, XOWST1, VALST1, HELAR3, HELST1, TYPST1, RSTST1, MKINT
DES These routines are used to process the CHECK_TYPE command which takes as an
argument a declaration and forms a word containing the apporopriate bits in
SPRBTS.
SPRZER Zeroes SPRBTS.
XOWST1 Gets bits corresponding to @XO.
VALST1 Gets bits corresponding to @VAL.
HELAR3 Gets the LPARRAY bit.
HELST1 Gets the ITEM or ITEMVAR bits.
TYPST1 Gets the @ALGLP bit.
RSTST1 Gets the remaining bits (i.e. PROCED, RES, BILTIN, DEFINE, SBSCRP, and
LPARRAY for a LPARRAY declaration.
MKINT Creates an integer out of the SPRBTS value and places it on the stack.
⊗
↑SPRZER: SETZM SPRBTS ;
SETOM NODFSW ; NO DEFINE TRIGGERING WHILE IN CHECK_TYPE.
POPJ P, ;
↑XOWST1: SKIPA A,XOTAB(B) ;
↑VALST1: MOVE A,VALTAB(B) ;
JRST ENDFRM ;
↑HELAR3: MOVEI A,LPARRAY ;
IORM A,SPRBTS ;
↑HELST1:
↑TYPST1: SKIPA A,TYPTAB(B) ;
↑RSTST1: MOVE A,CHKTAB(B) ;
ENDFRM: IORM A,SPRBTS ;
POPJ P, ;
↑MKINT: SETZM NODFSW ; ALLOW DEFINE TRIGGERING TO HAPPEN AGAIN.
MOVE A,SPRBTS ;
JRST MKINT2 ; MAKE AN INTEGER AND PLACE IT ON THE STACK.
DSCR FFPUSH, FFPOP
PRO FFPUSH, FFPOP
DES These rotines are used to save and restore the DEFLUK bit of FF on a QSTACK
pointed to by DEFDLM. This is necessary due to compile-time variables whose
definition may cause other macros to be called. DEFLUK is used to indicate
that a macro body is about to be scanned or a set of actual parameters to a
macro are about to be scanned.
FFPUSH Saves the DEFLUK bit of FF on a QSTACK pointed to by DEFDLM (actually save
the entire value of FF).
FFPOP Restores the DEFLUK bit of FF from the QSTACK pointed to by DEFDLM.
⊗
↑FFPUSH: MOVEI LPSA,DEFDLM ; GET QSTACK POINTER
MOVE A,FF ; A CONTAINS ITEM TO BE PUSHED IN QSTACK
TLO FF,DEFLUK ; TURN ON DEFLUK BIT IN FF
JRST BPUSH ; PUSH IN QSTACK
↑FFPOP: MOVEI LPSA,DEFDLM ; GET STACK POINTER
PUSHJ P,BPOP ; POP TOP OF QSTACK INTO A
TLZ FF,DEFLUK ; RESTORE DEFLUK BIT OF FF TO PREVIOUS VALUE
TLNE A,DEFLUK ;
TLO FF,DEFLUK ;
POPJ P, ;
DSCR DLMPSH, DLMPOP
PRO DLMPSH, DLMPOP
DES These routines are used to save and restore the DEFLUK bit of FF and the value
of the DLMSTG flag after encountering the DEFINE reserved word and after
encountering the = sign in a macro definition. This is necessary so that macro
names will be properly entered in the symbol table.
DLMPSH Saves the current value of DLMSTG and sets it to zero. Also saves the
current value of the DEFLUK bit of FF and sets it to zero.
DLMPOP Restores the value of DLMSTG from the stack. Also restores the DEFLUK bit
of FF.
⊗
↑DLMPSH: QPUSH(LOKDLM,DLMSTG) ; SAVE DLMSTG
SETZM DLMSTG ; DON'T LOOK FOR DELIMITED STRINGS
MOVEI LPSA,DEFDLM ; GET STACK POINTER
MOVE A,FF ;
TLZ FF,DEFLUK ; STRINGS SCANNED IN NON-MACRO MODE
JRST BPUSH ; PUSH IN QSTACK
↑DLMPOP: QPOP(LOKDLM,DLMSTG) ; RESTORE DLMSTG
JRST FFPOP ; RESTORE DEFLUK
DSCR CPSHBT, CPOPBT, DPSHBT, DPOPBT
PRO CPSHBT, CPOPBT, DPSHBT, DPOPBT
DES These routines are used to save and restore bits before and after conditional
compilation and macro definitions. This enables declarations to be interrupted
without having the partially accumulated BITS value destroyed when expressions
are looked up or string constants created.
CPSHBT Saves current BITS value during conditional compilation.
CPOPBT Restores the value of BITS after conditional compilation.
DPSHBT Saves current BITS value during a macro definition.
DPOPBT Restores the value of BITS after a macro definition.
⊗
↑CPSHBT: QPUSH(CBTSTK,BITS) ;
SETZM BITS ;
POPJ P, ;
↑CPOPBT: QPOP(CBTSTK,BITS) ;
POPJ P, ;
↑DPSHBT: QPUSH(DBTSTK,BITS) ;
SETZM BITS ;
POPJ P, ;
↑DPOPBT: QPOP(DBTSTK,BITS) ;
POPJ P, ;
DSCR CPSHEN, CPSHEY, CPOPET
PRO CPSHEN, CPSHEY, CPOPET
DES These routines are used to allow parser switching in the bodies of WHILEC,
CASEC, FORC, and FORLC statements. This enables one to conditionally compile
these bodies. The routines serve to set and reset a flag which is kept in a
QSTACK pointed at by ENDCTR. This flag indicates whether parser switching
should occur when an ENDC is seen (i.e. if it is terminating a WHILEC, CASEC,
FORC, or FORLC body, then no triggering should occur).
CPSHEN Pushes a -1 on the QSTACK indicating that an ENDC seen with this value
on top of the QSTACK is not to serve as a parser switching trigger.
CPSHEY Pushes a zero on the QSTACK indicating that an ENDC seen with this value on
the top of the QSTACK is to serve as a parser switching trigger.
CPOPET Pops the QSTACK pointed to by ENDCTR when one is done with a particular
ENDC parser switching trigger mode.
⊗
↑CPSHEY: TDZA A,A ;
↑CPSHEN: SETOM A ;
QPUSH(ENDCTR) ;
POPJ P, ;
↑CPOPET: QPOP(ENDCTR) ;
POPJ P, ;
DSCR DCLNT1,DCLNT2
PRO DCLNT1,DCLNT2
DES These routines are used for the DECLARATION and EXPR_TYPE commands.
DCLNT1 Same as DCLNT2 for EXPR_TYPE.
DCLNT2 This routine is used to process a DECLARATION(varname) command which looks
up the varname in the symbol table and returns an integer having the value
of the $TBITS entry in the symbol table. If the variable has not been
declared, then a zero is returned. Note that macro names are not expanded
here. Also, turn off the OWN bit if LPARRAY or SBSCRP are on and
TOPLEV ∧¬[XWD EXTRNL,GLOBL].
⊗
↑DCLNT1: SKIPA A,GENLEF+1 ; GET SEMBLK FOR EXPR_TYPE
↑DCLNT2: SKIPE A,GENLEF ; GET $TBITS VALUE IF DECLARED - ZERO
MOVE A,$TBITS(A) ; OTHERWISE.
TLNN A,SBSCRP ; TURN OFF OWN BIT IF LPARRAY OR SBSCRP AND
TRNE A,LPARRAY ; TOPLEV ∧¬[XWD EXTRNL,GLOBL].
TLNN FF,TOPLEV ;
JRST MKINT1 ;
TDNN A,[XWD EXTRNL,GLOBL] ;
TLZ A,OWN ;
MKINT1: TLZ FF,NOMACR ; TURN MACRO EXPANSION BACK ON IF OFF
MKINT2: PUSHJ P,CREINT ; CREATE INTEGER CONSTANT SEMBLK
MOVEM PNT,GENRIG ; SET THE SEMANTIC STACK ENTRY TO
; THE SEMBLK ADDRESS OF THE NUMBER.
POPJ P, ;
DSCR DCLBEG,DCLEND
PRO DCLBEG,DCLEND
DES These routines are used to process EXPR_TYPE command which takes an arbitrary
expression as an argument and returns an integer having the value of the $TBITS
entry in the symbol table for the appropriate type. The difference between it
and the DECLARATION command is that the latter does not expand macro names thus
enabling the user to determine if variables have been used as macro names.
Also, identifiers must have been previously declared if used here.
DCLBEG Saves contents of accumulators and $SBITS values of their contents to
enable recovery from damage done by code generators. Also turn off code
generation, and save ADEPTH, PCNT, and SDEPTH.
DCLEND Restore contents of accumulators and $SBITS values of their contents.
Also restore PCNT and SDEPTH, and make sure ADEPTH has not changed.
⊗
↑DCLBEG:
TLNN FF,LPPROG
PUSHJ P,OKSTAC
MOVE A,[XWD ACKTAB,ACKSAV] ; SAVE ACKTAB IN ACKSAV
BLT A,ACKSAV+12 ;
MOVEI D,12 ;
LPAT: MOVE PNT,ACKTAB(D) ; SAVE $SBITS IN SBSAV
MOVE SBITS,$SBITS(PNT) ;
MOVEM SBITS,SBSAV(D) ;
SOJGE D,LPAT ;
SETOM NOEMIT ; TURN OFF EMITTER
MOVE TEMP,ADEPTH ;
MOVEM TEMP,ADPTSV ;
MOVE TEMP,PCNT ;
MOVEM TEMP,PCNTSV ;
MOVE TEMP,SDEPTH ;
MOVEM TEMP,SDPTSV ;
POPJ P, ;
↑DCLEND: MOVEI D,12 ;
BEGLP: MOVE PNT,ACKTAB(D) ;
CAMN PNT,ACKSAV(D) ; IF ACKTAB IS SAME AS ACKSAV, THEN JUST
JRST AFTRM2 ; RESTORE $SBITS
HRRZ C,$ACNO(PNT) ; CHECK IF AC HAS ALREADY BEEN REMOPED AND
CAIE C,(D) ; IS THUS VALID
JRST AFTREM ; YES
PUSHJ P,CLEAR ;
PUSHJ P,REMOP ;
AFTREM: MOVE PNT,ACKSAV(D) ; RESTORE ACKTAB, $SBITS, AND $ACNO
MOVEM PNT,ACKTAB(D) ;
AFTRM2: MOVE SBITS,SBSAV(D) ;
MOVEM SBITS,$SBITS(PNT) ;
HRRM D,$ACNO(PNT) ;
ENDLP: SOJGE D,BEGLP ;
SETZM NOEMIT ; TURN EMITTER BACK ON
MOVE TEMP,ADPTSV ; IF ADEPTH CHANGED WHILE PROCESSING
CAME TEMP,ADEPTH ; EXPR_TYPE THEN ERROR SINCE PARAMETER
ERR <DRYROT - DCLEND FOR EXPR_TYPE> ; STACK WILL BE OUT OF SYNCH
MOVE TEMP,PCNTSV ;
MOVEM TEMP,PCNT ;
MOVE TEMP,SDPTSV ;
MOVEM TEMP,SDEPTH ;
POPJ P, ;
DSCR CNDRCY, CNDRCN, CNDRCP
PRO CNDRCY, CNDRCN, CNDRCP
DES These routines are used to keep track of whether macros should be
expanded in the false part of conditional compilation. IFCREC is
used to denote the current mode and RECSTK points to the top of
the qstack used to store the currently overridden values of IFCREC
CNDRCY This routine is used to save the current IFC mode and set it
to no expansion of macros in the false part of conditional
compilation,
CNDRCN This routine is used to save the current IFC mode and set it
to expand macros in the false part of conditional compilation.
CNDRCP This routine is used to restore the previous IFC mode.
⊗
↑CNDRCY: QPUSH(RECSTK,IFCREC) ;
SETOM IFCREC ;
POPJ P, ;
↑CNDRCN: QPUSH(RECSTK,IFCREC) ;
SETZM IFCREC ;
POPJ P, ;
↑CNDRCP: QPOP(RECSTK,IFCREC) ;
POPJ P, ;
DSCR PSHLST, POPLST
DES PSHLST, POPLST
DES These routines are used to indicate whether one is in the false part of
conditional compilation or in the conditional compilation parser. This
information is used by the SCANNER so that listing files can hopefully
reflect the true program that is being compiled. The basic action of
the SCANNER is to test the CNDLST flag when it is about to stack a result
on the parse stack and if one is in the conditional compilation parser,
then the listing buffer pointer is reset to the value it had prior to
scanning the parse token in question.
PSHLST This routine is used to indicate that listing should not be happening now.
POPLST This routine is used to indicate that one is to revert to the previous mode
of listing output.
⊗
↑PSHLST: QPUSH(LSTSTK,CNDLST) ; SAVE PREVIOUS COND. COMP. LISTING STATE
SETOM CNDLST ; CEASE LISTING
POPJ P, ;
↑POPLST: QPOP(LSTSTK,CNDLST) ; RESTORE PREVIOUS COND. COMP. LISTING STATE
POPJ P, ;
DSCR SETRDF, SETEDF, DEFOFF
PRO SETRDF, SETEDF, DEFOFF
DES These routines are used indicate when a REDEFINE or an EVALDEFINE are
in progress.
SETRDF This routine turns on the REDEFN flag which indicates that a
REDEFINE of a macro is in progress.
SETEDF This routine turns on the EVLDEF flag which indicates that an
EVALDEFINE is in progress and thus the following macro name is
expanded.
DEFOFF This routine turns off the REDEFN and EVLDEF flags.
⊗
↑SETRDF: SETOM REDEFN ;
POPJ P, ;
↑SETEDF: SETOM EVLDEF ;
POPJ P, ;
↑DEFOFF: SETZM REDEFN ;
SETZM EVLDEF ;
POPJ P, ;
DSCR INTSCN, ASGENT
PRO INTSCN, ASGENT
DES These routines are used to implement the ASSIGNC construct which
allows assignment to macro formals.
INTSCN This routine turns on the ASGFLG flag which indicates that
the next internal representation of a macro is not to be
expanded. Instead the integer value of the macro formal
parameter number is returned.
ASGENT This routine is used to assign the macro body to the macro
formal parameter.
⊗
↑INTSCN: SETOM ASGFLG ;
POPJ P, ;
↑ASGENT: MOVE LPSA,GENLEF+1 ; ASSIGNC NEW BODY
EXCH SP,STPSAV ; SET UP TO USE STRING STACK
MOVSS POVTAB+6 ;
MOVE TBITS,$TBITS(LPSA) ; SEE IF STRING AND IF NOT CONVERT
TRNE TBITS,STRING ; TO A STRING
JRST ASGCON ; IT IS A STRING
PUSH P,$VAL(LPSA) ; NO, CONVERT TO A STRING,
PUSHJ P,REMOPL ; REMOVE NUMERIC SEMBLK
PUSHJ P,CVS ; WILL LEAVE RESULT STRING ON SP-STACK
JRST POPSTR
ASGCON:
PUSH SP,$PNAME(LPSA) ; STACK THE STRING
PUSH SP,$PNAME+1(LPSA) ;
EXCH SP,STPSAV ;
PUSHJ P,URGSTR ; REMOVE BODY SEMBLK FROM STRING RING
FREBLK ; FREE IT
EXCH SP,STPSAV ;
POPSTR:
MOVE LPSA,DEFRNG ; GET SEMBLK OF ACTUAL
MOVE B,GENLEF+2 ; PARAMETER TO BE ASSIGNED TO,
GETIT: SOJE B,GOTIT ; REPLACE ITS $PNAME WITH NEW VALUE
RIGHT ,%RVARB, ; WHICH IS ON TOP OF SP STACK
JRST GETIT ;
GOTIT:
POP SP,$PNAME+1(LPSA) ;
POP SP,$PNAME(LPSA) ;
EXCH SP,STPSAV ;
MOVSS POVTAB+6 ;
SETZM ASGFLG ; TURN OFF ASSIGNC IN PROGRESS FLAG
POPJ P, ;
DSCR LETSET, LETENT
PRO LETSET LENENT
DES EXECS for syntax
LET ident=<reserved word>, .... , ... ;
The semantics of the reserved word is copied into the identifier.
This mechanism could be expanded to allow synonymating idents with
characters, so that characters could be returned to the letter set,
and to allow run-time expressions (LET FOO=1, FOO=FOO+1).
LTR: @IDD EXEC LETSET SCCAN 2 ¬LT1 #QCON
LT1: SG = @RESERVED →→ EXEC LETENT SCAN ....
⊗
↑LETSET: SETZM BITS ;NO BITS NOW
PUSHJ P,ENTERS ;ENTER IT RANDOMLY
SKIPN LPSA,NEWSYM ;BE CAREFUL
ERR <DRYROT AT LETSET> ;IN CASE ENTERS MAKES A MISTAKE
MOVEM LPSA,GENRIG ;RESULT, SO TO SPEAK
TLZ FF,NOMACR ;TURN OFF SPECIAL
POPJ P, ;DONE
↑LETENT: SKIPE GENLEF
ERR <SYNONYMS FOR RESERVED WORDS ONLY>
;; #MS# LET NOT COPYING TRIGGER BIT
MOVE LPSA,SYMTAB ;PREPARE TO LOOK IT UP
PUSHJ P,SHASH ;LOOK UP SYMBOL AGAIN, PNAME SHOULD
;STILL BE VALID
MOVE TEMP,NEWSYM ;SEMBLK FOR RESERVED WORD
MOVE TEMP,$TBITS(TEMP) ;THE TBITS
;; #MS#
MOVE PNT,GENLEF+2 ;NEW NAME FOR SAME THING
MOVEM TEMP,$TBITS(PNT) ;MAKE THEM EQUIVALENT
POPJ P, ;RETURN
↑TRIGOF: SETZM SWCPRS ; TURN OFF TRIGGERING ON IFC ...
SETOM NODFSW ; TURN OFF TRIGGERING ON DEFINE,
POPJ P, ; REDEFINE, EVALDEFINE, IFC ... SO
; THAT ONE CAN HAVE CONSTRUCTS
; SUCH AS LET DEFINE=REDEFINE
; LET IFC=IFCR
↑TRIGON: SETOM SWCPRS ; TURN ON TRIGGERING ON IFC ...
SETZM NODFSW ; TURN ON TRIGGERING ON DEFINE,
POPJ P, ; REDFINE, AND EVALDEFINE
DSCR TWCOND,SWICHP,SWPOFF,PSWICH,OKEOF
PRO TWCOND SWICHP SWPOFF PSWICH OKEOF
DES EXECS for conditional assembly
TWCOND is responsible for indicating on the parse stack whether or not a
condition is true. In the productions one assumes the condition
is true, and thus if it is false then TWCOND will change the parse
stack token to false.
SWICHP switches parsers from the conditional parser back to the main sail
parser. This entails saving the processor descriptor of the
conditional parser (semantic stack pointer, parse stack pointer,
production stack pointer, and number of calls to scanner that
have still not yet been processed), as well as restoring the
processor descriptor of the main sail parser.
PSWICH does the reverse of SWICHP when one wants to switch from the main
sail parser to the conditional parser. The actual code for this
can be found in SYM at the end of the identifier scan routine.
Note that this is not a procedure but it is described here for
the sake of completeness.
SWPOFF turns the switchparser switch (SWCPRS) off when one would want to
switch to a parser that is already executing. This would typically
happen when one has evaluated a condition to be false; since the
conditional parser would now be in control and is in the process
of swallowing characters until IFC ... ELSEC ... ENDC and nested
occurrences are eliminated and an ENDC or ELSEC appears unnested.
Thus what one has is a flag that says don't interrupt the con-
ditional parser.
OKEOF Is not strictly a part of conditional assembly. It was added to
allow parser to see EOF as a token on some occasions. This allows
code after DONES to scan to EOF, listing rest of file (final END
bug). Will also lead the way to more parsers, like the conditional
parser. OKEOF simply turns on SCNWRD's EOFOK bit...SCANNER
then returns EOF token when appropriate.
⊗
↑TWCOND: GETSEM (1) ; GET SEMANTICS OF ARITHMETIC EXPRESSION
MOVE TEMP,%CFLS1 ; ASSUME COMPARE FALSE (0 OR NOT CONSTANT)
TLNE TBITS,CNST ; CONSTANT?
SKIPN $VAL(PNT) ; ZERO?
MOVEM TEMP,PARRIG ; YES, CHANGE FROM CTRU1 TO CFLS1
POPJ P, ; RETURN
↑SWPOFF: SETZM SWCPRS ; TURN OFF SWITCH PARSEERS FLAG
POPJ P, ; RETURN
↑OKEOF: MOVE TEMP,SCNWRD ;TURN ON EOFOK FOR SCANNER (SCANNER ALWAYS
TLO TEMP,EOFOK ; TURNS IT OFF, SO PRODUCTIONS MUST TURN
MOVEM TEMP,SCNWRD ; IT ON EACH TIME (PROBABLY NOT NECESSARY,
POPJ P, ; BUT SCANNER SOMETIMES HAS TO TURN IT OFF
; UNDER CURRENT IMPL, SO...)
↑SETFL: MOVE LPSA,GENLEF+2 ; MACRO PSEUDONYM SEMBLK
MOVE LPSA,$VAL2(LPSA) ; ADDRES OF ACTUAL PARAMETER RING SEMBLK
MOVEM LPSA,DEFRN2 ; STORE IT IN DEFRN2
JRST SETFL1 ; GO CONTINUE PREPARING FOR A MACRO CALL
↑SETFR: MOVE LPSA,GENLEF+2 ; GET MACRO PSEUDONYM SEMBLK
PUSHJ P,MKFRLP ; MAKE A FORC LOOP PARAMETER (I.E. LOOP VAR)
POP SP,PNAME+1 ; SECOND WORD OF STRING DESCRIPTOR
POP SP,PNAME ; FIRST WORD OF STRING DESCRIPTOR
EXCH SP,STPSAV ; RETURN STRING POINTER (EXCH IN MKFRLP)
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
GETBLK NEWSYM ; GET A SEMBLK FOR THE FORC LOOP PARAMETER WHICH
HRROI TEMP,PNAME+1 ; IS TREATED AS IF IT IS AN ACTUAL PARAMETER TO
POP TEMP,$PNAME+1(LPSA) ; A MACRO AND IS THUS ALWAYS PUT ON THE STRING
POP TEMP,$PNAME(LPSA) ; RING. NOTE THAT IT IS NOT HASHED AND IS
MOVE TEMP,[XWD CNST,STRING] ; NOT PLACED ON THE STRING CONSTANT RING.
MOVEM TEMP,$TBITS(LPSA) ; THUS WHEN ONE IS THROUGH WITH THE FORC BODY
PUSHJ P,RNGSTR ; ITS LOOP PARAMETER'S SEMBLK IS FREED.
MOVEM LPSA,DEFRN2 ;
SETFL1: EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
MOVE LPSA,GENLEF+1 ; GET FORC OR FORLC BODY STRING SEMBLK
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0")
MOVE LPSA,GENLEF+2 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
JRST PRCAL1 ; GO CONTINUE PREPARING FOR A MACRO CALL
↑SETCSE: EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
MOVE LPSA,GENLEF+1 ; GET THE CASEC BODY STRING SEMBLK
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0")
MOVE LPSA,GENLEF+3 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
JRST PRECAL ; GO CONTINUE PREPARING FOR A MACRO CALL
↑SETWHL: EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
PUSH SP,[XWD 0,4] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[ASCII "IFC "]] ; FIRST WORD OF PSEUDO MACRO
MOVE LPSA,GENLEF+3 ; GET THE CONDITION STRING SEMBLK
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSHJ P,CAT ; CONCATENATE
PUSH SP,[XWD 0,7] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[ASCII " THENC "]] ; END OF CONDITION
PUSHJ P,CAT ; CONCATENATE
MOVE LPSA,GENLEF+1 ; GET THE PSEUDO MACRO BODY STRING SEMBLK
PUSH SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
PUSH SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
PUSHJ P,CAT ; CONCATENATE
PUSHJ P,CTENDC ; APPEND COND COMP ENDING (" ENDC 177 0")
MOVE LPSA,GENLEF+2 ; LPSA MUST CONTAIN MACRO PSEUDONYM SEMBLK
PRECAL: SETZM DEFRN2 ; WHILEC AND CASEC HAVE NO PARAMETER RINGS
PRCAL1: POP SP,PNAME+1 ; FIRST WORD OF STRING DESCRIPTOR
POP SP,PNAME ; SECOND WORD OF STRING DESCRIPTOR
PUSH P,LPSA ; ENTER CONDITIONAL COMPILATION BODY STRING AND
PUSHJ P,STRINS ; LINK TO MACRO PSEUDONYM SEMBLK
POP P,LPSA ;
HRLM PNT,%TLINK(LPSA) ;
EXCH SP,STPSAV ; RETURN STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
MOVE TBITS2,SCNWRD ; SYNCH SCAN COMTROL WORD
JRST ACPMED ; GO PREPARE FOR A MACRO CALL (IN SCANNER)
↑CTENDC: PUSH SP,[XWD 0,8] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[BYTE (7) " ","E","N","D","C"," ",177,0]] ; END
; OF PSEUDO MACRO BODY
JRST CAT ; CONCATENATE
↑SWICHM: MOVE LPSA,GENLEF+2 ; PSEUDO MACRO NAME SEMBLK
JRST CONTXT ; PREPARE FOR WHILEC BODY SCAN
↑SWCHFR: MOVE LPSA,GENLEF ; PSEUDO MACRO NAME SEMBLK
PUSHJ P,MKFRLP ; GET NEW FORC LOOP PARAMETER
MOVE LPSA,DEFRNG ; SEMBLK OF PSEUDO MACRO PARAMETER
POP SP,$PNAME+1(LPSA) ; SECOND WORD OF STRING DESCRIPTOR
POP SP,$PNAME(LPSA) ; FIRST WORD OF STRING DESCRIPTOR
EXCH SP,STPSAV ; RETURN STRING POINTER (EXCH IN MKFRLP)
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
↑SWCHFL: MOVE LPSA,GENLEF ; PSEUDO MACRO NAME SEMBLK
JRST CONTXT ; PREPARE FOR FORC OR FORLC BODY SCAN
↑MKFRLP: EXCH SP,STPSAV ; GET STRING POINTER
MOVSS POVTAB+6 ; ENABLE CORRECT PDL OVERFLOW MESSAGE
PUSH P,$VAL2(LPSA) ; CURRENT VALUE OF FORC LOOP PARAMETER
PUSHJ P,CVS ; CONVERT TO STRING
PUSH SP,[XWD 0,2] ; LENGTH OF FOLLOWING STRING
PUSH SP,[POINT 7,[BYTE (7) 177,0]] ; MACRO PARAMETER ENDING
JRST CAT ; CONCATENATE
↑GTSTRT: PUSHJ P,GETCVI ; CONVERT FORC STARTING VALUE TO INTEGER
MOVEM PNT,$VAL2(LPSA) ; STORE IN $VAL2 OF MACRO PSEUDONYM SEMBLK
POPJ P, ; RETURN
↑GTSTEP: PUSHJ P,GETCVI ; CONVERT FORC STEP TO INTEGER
MOVEM PNT,$DATA(LPSA) ; STORE IN $DATA OF MACRO PSEUDONYM SEMBLK
POPJ P, ; RETURN
↑GETERM: PUSHJ P,GETCVI ; CONVERT FORC END VALUE TO INTEGER
MOVE LPSA,GENLEF+2 ; SEMANTICS OF MACRO PSEUDONYM
MOVEM PNT,$DATA2(LPSA) ; STORE IN $DATA2 OF MACRO PSEUDONYM SEMBLK
MOVE PNT,$VAL2(LPSA) ; GET FORC STARTING VALUE
PUSHJ P,TWNUM1 ; GO CHECK IF STARTING VALUE IS OUT OF RANGE
CAMN PNT,%CFLS1 ; STARTING VALUE OUT OF RANGE?
PUSHJ P,FFPUSH ; NO
POPJ P, ; RETURN
↑GETCVI: MOVE PNT,GENLEF+1 ; STRING SEMBLK TO BE CONVERTED TO INTEGER
GENMOV(CONV,INSIST!GETD,INTEGR) ; CONVERT
MOVE PNT,$VAL(PNT) ; GET INTEGER VALUE
MOVE LPSA,GENLEF+2 ; ADDRESS OF MACRO PSEUDONYM SEMBLK
POPJ P, ; RETURN
↑TWNUM: MOVE LPSA,GENLEF+1 ; ADDRESS OF FORC MACRO PSEUDONYM SEMBLK
MOVE PNT,$DATA(LPSA) ; FORC LOOP STEP VALUE
ADDB PNT,$VAL2(LPSA) ; INCREMENT CURRENT FORC LOOP VALUE
↑TWNUM1: SUB PNT,$DATA2(LPSA) ; SUBTRACT FORC LOOP END VALUE
SKIPL $DATA(LPSA) ; STEP NEGATIVE?
MOVN PNT,PNT ; NO, NEGATE STEP
JUMPGE PNT,GPOPJ ; DONE WITH LOOP IF POSITIVE
MOVE PNT,%CFLS1 ; TWIDDLE TO INDICATE END OF FORC LOOP
MOVEM PNT,PARRIG+1 ; SET PARSE STACK TO TWIDDLED VALUE
GPOPJ: POPJ P, ; RETURN
↑GETACT: MOVE LPSA,GENLEF+2 ; ADDRESS OF FORLC MACRO PSEUDONYM SEMBLK
HRLZI TEMP,1 ; SET PARAMETER COUNT TO ZERO
MOVEM TEMP,$VAL(LPSA) ; STORE IT (incredibly imaginative comment)
MOVE TBITS2,SCNWRD ; SYNCH SCAN CONTROL WORD
PUSHJ P,SCNACT ; SCAN A LIST OF ACTUAL PARAMETERS WHICH
; CAN HAVE A SPECIAL DELIMITER DECLARATION
; (IN SCANNER)
MOVE TEMP,DEFRN2 ; DEFRN2 POINTS TO RING OF ACTUAL PARAMETERS
MOVEM TEMP,$VAL2(LPSA) ; STORE IT IN $VAL2 OF FORLC MACRO PSEUDO-
; NYM SEMBLK SO THAT THE MACRO BODY CAN BE
; PROPERLY SCANNED FOR PARAMETER SUBSTITU-
; TIONS
POPJ P, ; RETURN
↑TWACT: MOVE LPSA,DEFRNG ; GET FORLC ACTUAL PARAMETER RING
HRRZ LPSA,%RVARB(LPSA) ; GET NEXT PARAMETER IF NOT DONE
JUMPN LPSA,.+3 ; FORLC ACTUAL PARAMETER LIST EXHAUSTED
MOVE TEMP,%CFLS1 ; TOKEN TO BE TWIDDLED
MOVEM TEMP,PARRIG+1 ; SET PARSE STACK STRAIGHT
PUSH P,LPSA ; REMOVE CURRENT FORLC PARAMETER FROM THE STRING
MOVE LPSA,DEFRNG ; RING AND FREE ITS STRING SEMBLK
PUSHJ P,URGSTR
POP P,LPSA;
FREBLK DEFRNG ;
MOVEM LPSA,DEFRNG ; SET DEFRNG TO CURRENT ACTUAL PARAMETER
POPJ P, ; RETURN
↑TWCSCN: MOVE TEMP,GENLEF+3 ; ADDRESS OF CASEC MACRO PSEUDONYM SEMBLK
SOSE $VAL2(TEMP) ; RIGHT CASEC?
POPJ P, ; NO, RETURN
PUSHJ P,CPSHEN ; SET ENDC DOESN'T TRIGGER A PARSER SWITCH FLAG
SETOM SWCPRS ; PARSER SWITCHING IS OK (I.E. IFC IN BODY OF CASEC
; TO BE EXECUTED)
MOVE TEMP,%CTRU1 ; TWIDDLE SO NEXT CASEC WILL BE SCANNED
MOVEM TEMP,PARRIG ; SET PARSE STACK STRAIGHT
POPJ P, ; RETURN
↑FREMBN: MOVE A,GENLEF+2 ; GET RID OF FORMAL PARAMETER LIST TO FORC
MOVE LPSA,$ACNO(A) ; AND WHICH IS NEVER EXECUTED AS
PUSHJ P,KILLST ; WELL AS RESTORE THE PROPER LEVEL AND
MOVE LPSA,GENLEF+2 ; VARB
PUSHJ P,CLENUP ;
JRST FRMBFF ;
↑FREMBF: SKIPA LPSA,GENLEF ; FORC, AND FORLC MACRO PSEUDONYM SEMBLK
↑FREMBW: MOVE LPSA,GENLEF+2 ; WHILEC MACRO PSEUDONYM SEMBLK ADDRESS
FRMBFF: PUSH P,LPSA ; CHECK IF THROUGH WITH PSEUDO MACRO STRING AND IF
HLRZ LPSA,%TLINK(LPSA) ; YES FREE ITS SEMBLK SO THE STRING WILL BE
PUSHJ P,REMOPL ; GARBAGE COLLECTED
PUSHJ P,BLKFRE ; FREE MACRO PSEUDONYM SEMBLK
MOVEI TEMP,2 ; AT THIS POINT ONE STILL HAS 177,0 TO SCAN SO SET
HRRM TEMP,PNEXTC-1 ; PNEXTC-1 TO POINT TO THE 177,0 AS A STRING SO IT
POPJ P, ; WON'T BE LOST IN CASE OF A GARBAGE COLLECTION
↑FRMBCE:MOVE LPSA,GENLEF+3 ; CASEC SEMBLK ADDRESS
SKIPLE $VAL2(LPSA) ; CHECK IF NONE OF THE CASEC CASES WERE
PUSHJ P,CLENUP ; EXECUTED; IF SO RESTORE VARB AND LEVEL
FREBLK GENLEF+3 ; DELETE CASEC PSEUDONYM SEMBLK
POPJ P, ; RETURN
↑FRMBCT: MOVE LPSA,GENLEF+2 ; LAST TRUE CASEC BODY SEMBLK
HLRZ LPSA,%TLINK(LPSA) ; LAST TRUE CASEC BODY SEMBLK
PUSHJ P,REMOPL ; CHECK IF THROUGH WITH STRING AND IF YES FREE ITS
; SEMBLK SO THE STRING WILL BE GARBAGE COLLECTED
MOVE LPSA,GENLEF+2
HRRZS %TLINK(LPSA) ; MACRO PSEUDONYM NO LONGER HAS A BODY LINK
POPJ P, ; RETURN
CLENUP: MOVE TEMP,$ADR(LPSA) ; RESTORE VARB AND LEVEL WHEN CASEC, FORC,
MOVEM TEMP,VARB ; AND FORLC ARE NOT EXECUTED. EXPECTS
SOS LEVEL ; LPSA TO CONTAIN THE ADDRESS OF THE
JRST FREBUK ; RELEVANT SEMBLK
↑TMACIN: SKIPE PRSCON ; DETERMINE WHICH PARSER IS CURRENTLY SUSPENDED AND
SKIPA A,SSCWSV ; GET A POINTER TO ITS SCNWRD STACK. THIS IS USED
MOVE A,CSCWSV ; TO SET THE MACIN BIT IN SYNCH WITH MACROS THAT
POPJ P, ; MIGHT HAVE ENDED WHILE THE SUSPENDED OR MOST
; RECENTLY ACTIVATED PARSER WERE INACTIVE.
↑TOMACN: PUSHJ P,TMACIN ; CHANGE MACIN BIT OF PARSER TO BE RESUMED TO
LDB TBITS2,[POINT 1,SCNWRD,6] ; THE VALUE OF THE MACIN BIT OF THE
DPB TBITS2,[POINT 1,(A),6] ; CURRENT PARSER.
POPJ P, ;
↑FRMACN: PUSHJ P,TMACIN ; CHANGE THE MACIN BIT OF THE CURRENT PARSER TO
LDB TBITS2,[POINT 1,(A),6] ; THE VALUE OF THE MACIN BIT OF THE SUSPENDED
DPB TBITS2,[POINT 1,SCNWRD,6] ; PARSER.
POPJ P, ;
SUBTTL EXECS for Entry Declaration
DSCR ENTMAK, ENTOUT
PRO ENTMAK ENTOUT
DES EXECS for syntax
ENTRY id1, id2, ...., ... ;
Must appear before initial BEGIN
SEE comment below DSCR for details
⊗
Comment ⊗ ENTRY code -- has two functions:
1. Denote that this compilation is not the main program
but a collection of separately compiled procedures.
2. Create an entry block so that these programs
can be loaded from a library.
The syntax:
BB0: ENTRY → EXEC ENTENT SCAN 2 ¬ ENT
BEGIN → BLAT BEGIN EXEC ENTOUT DWN SCAN ¬DS
...
ENT: @I , → EXEC ENTMAK SCAN 2 ¬ ENT
@I ; → EXEC ENTMAK SCAN ¬ BB0
⊗
↑ENTENT: TLZE FF,MAINPG ;NO STARTING ADDRESS FOR THIS PROGRAM
HLLZS ENTTAB ;RESET FIRST TIME IN
POPJ P,
↑ENTMAK: HRL LPSA,PNAME ;COUNT
HRR LPSA,PNAME+1 ;BYTE POINTER FOR ENTRY SYMBOL
PUSHJ P,RAD52 ;MAKE RADIX50 FOR ENTRY
AOS B,ENTTAB ; → NEXT ENTRY
HRRZS B ;CLEAR LEFT HALF
MOVEM A,ENTTAB+1(B) ;TO ENTRY TABLE
CAIGE B,22 ;FULL?
POPJ P, ;NO
↑ENTOUT:
MOVEI B,ENTTAB ;PUT OUT BLOCK IF THERE IS
TLNN FF,MAINPG ; ONE
JRST GBOUT
POPJ P, ;THERE IS NONE FOR SURE
SUBTTL EXECS for Storage Allocation at end of Procedure
DSCR ALOT
DES Allocation routine -- called by PRUP and DONES EXECS, allocates
storage, issues fixups and symbols for all locals in Procedure
(outer Block)
PAR VARB-rings on BLKLIS Qstack
RES ALIMS, ALOCALS, SLIMS, SLOCALS, LLIMS, LLOCALS as described
in subsequent comments
SEE comment below DSCR for details
⊗
COMMENT ⊗
This is the code invoked to allocate space for variables on the
VARB ring. Symbols are also output to the loader, for use by DDT and
the world. As each block is closed, the portion of the VARB ring developed
for that block is saved by a pointer in the table BLKLIS, and the count
BLKIDX is incremented. It is the job of this code to run through all
the VARB information stored on this list, and allocate.
There is a bit in FF, called ALLOCT which determines whether
this code actually allocates storage, or merely counts things.
The counts are necessary for deciding how exit and entry code for
recursive procedures should be generated. These counts are:
ALOCAL (arithmetic stack locals) and SLOCAL (string stack
locals). FIRSYM and LSTSYM point to the first and last symbols allocated.
⊗
ZERODATA (VARIABLE-ALLOCATION VARIABLES)
COMMENT ⊗
ALIMS -- [Semantics of last,Semantics of first] -- set up by ALLOT
to indicate the range of non-string variables allocated. This
is used by PROCED after the first (non-allocating) call on ALLOT
and before the second (allocating) call, to set up saving
and restoring instructions (BLT) for these variables for
recursive Procedures. The non-allocating run allows these extra
instructions to be inserted before fixed locations are assigned
to the variables (see ALLOT's DSCRs).
⊗
↑↑ALIMS: 0
;ALOCALS -- a count of the number of non-string locals -- set up
; for the same reasons given above for ALIMS
↑↑ALOCALS: 0
;BLKCNT -- temp used when outputing symbol names -- see DOSYM's
; DSCR for details
↓BLKCNT: 0
;FIRSYM -- Semantics of first variable allocated by ALOT -- used to
; set up ALIMS, SLIMS, LLIMS
↓FIRSYM: 0
;LLIMS -- ALIMS-like thing for sets -- ALIMS includes LLIMS in its
; range -- used to put together Set Link Blocks -- see ALLOT
↓LLIMS: 0
;LLOCAL -- ALOCAL-type count of number of Sets this Procedure
↓LLOCAL: 0
;LSTSYM -- Semantics of last variable allocated by ALOT -- used to
; set up ALIMS, SLIMS, LLIMS
↓LSTSYM: 0
;SLIMS -- ALIMS-like thing for strings. Used for above-
; mentioned purposes; also to put together String Link Blocks
; See ALLOT, LNKOUT
↑↑SLIMS: 0
;SLOCALS -- ALOCALS-type count for # Strings this Procedure
↑↑SLOCALS: 0
ENDDATA
↑ALOT: ;ROUTINE TO HANDLE ALLOCATION
;OF CORE AND THINGS FOR VARIABLES.
SETZM FIRSYM
TLNN FF,ALLOCT ;ALLOCATING REALLY?
JRST ALSYMS ; NO, IGNORE ADCONS THIS TIME AROUND
;ALLOCATE ADDRESS CONSTANTS. INFORMATION ABOUT THEM IS
;SAVED ON THE VARB RING HOMED AT ADRTAB. SEE PROCED
;FOR DETAILS OF HOW THE ADDRESS CONSTANTS ARE USED.
ADCGO: HRRZ LPSA,TPROC ;GET LEVEL OF PROCEDURE WHOSE LOCALS
LDB TEMP,PLEVEL ; ARE BEING DEFINED
MOVEM TEMP,THSLVL#
HRRZ LPSA,ADRTAB ;ADDRESS CONSTANTS.
JUMPE LPSA,ALSYMS ;NONE
RADA: MOVE SBITS,$SBITS(LPSA) ;IF A TEMP, IT IS IDENTIFIED BY
TLNN SBITS,ARTEMP ;ITS SEQUENCE NO, ELSE BY SEMANTIC ADR
JRST RADAA ;NOT A TEMP
MOVE A,$PNAME(LPSA) ;THE ID NO FOR THIS TEMP
MOVE PNT,TTEMP ;SEARCH THE TEMP LIST FOR IT
RADLP: JUMPE PNT,NOUNLK ;NOT THERE, TRY LATER
CAMN A,$PNAME(PNT) ;IS THIS THE RIGHT INFO?
JRST RADAB ; YES, PUT OUT ADCON
HLRZ PNT,%RVARB(PNT) ;NO, KEEP LOOKING
JRST RADLP
RADAA: HLRZ PNT,%TLINK(LPSA) ;GET POINTER TO
RADAB: PUSHJ P,GETAD ;SEMANTICS OF SYMBOL WHOSE AD IS CONED.
TLNE SBITS,CORTMP ;IS THIS A CORE TEMP?
JRST OKRADA ; YES, PUT OUT THE ADCON
TLNE SBITS,ARTEMP
; ***** BUG TRAP
ERR <DRYROT -- RADA>,1
TLNE TBITS,CNST
JRST OKRADA ;EACH WILL APPEAR BUT ONCE
TDZ SBITS,[¬LLFLDM] ;GET LEVEL ONLY
CAMGE SBITS,THSLVL ;IF ADCON CORRESPONDS TO
JRST NOUNLK ;SOMETHING IN THIS PROC, PUT IT OUT
OKRADA:
HRLZ B,$ADR(LPSA) ;ADCON FIXUP
JUMPE B,RADC ;WAS NOT USED.
HRR B,PCNT
PUSHJ P,FBOUT ;FIXUP FOR THE ADCON.
HLL A,$ADR(LPSA) ;TYPE BITS TO INSERT.
HRRI A,FXTWO!NOUSAC
;; #NQ# ↓ A STRING ITEMVAR IS NOT A STRING
TDNN TBITS,[SBSCRP,,ITMVAR] ;IF ¬(SBSCRP∨ITEMVAR)∧STRING
TRNN TBITS,STRING ; USE 2D WORD FIXUP
TRZ A,FXTWO ;ELSE REGULAR OLD FIXUP
PUSHJ P,EMITER ;USE HIM TO OUTPUT THE WORD.
RADC: PUSHJ P,URGADR ;REMOVE FROM ADRTAB
FREBLK (LPSA)
NOUNLK: LEFT ,%RVARB,ALSYMS ;LOOP UNTIL DONE.
JRST RADA
Comment ⊗
NOW ALLOCATE STORAGE FOR VARIABLES.
When a block has been compiled, the pointer to its block entry (and thus to
its VARB ring of locals) is placed in the next free location in BLKLIS
(using BLKIDX QPDP). BLKIDX is cleared at the beginning of each procedure
compilation, and the old value is stored. In all that follows, all and only
those blocks whose pointers lie in the current BLKLIS will be processed.
In order to keep things together for BLT'ing on and off the stacks, strings
are allocated first. Then arrays. Then all else. The routine "ALLO" is
called to actually look for things to allocate. It uses the mask set up in
TBITS2.
⊗
ALSYMS: MOVEI TBITS2,STRING ;FIRST ALLOCATE STRINGS.
REN <
PUSHJ P,LOSET ;SWITCH TO DATA SEGMENT
>;REN
SETZM CSPOS ;SET STACK DISPL=0
PUSHJ P,ALLO ;GO DO IT.
LSH PNT2,1
MOVEM PNT2,SLOCAL ;SAVE COUNT OF STRINGS ALLOCATED.
MOVEM A,SLIMS ;LIMITS OF SYMBOLS.FOR STRINGS
MOVE PNT2,CSPOS ;
MOVEM PNT2,SSDIS ;STRING STACK DISPL DUE TO LOCALS
MOVEI PNT2,2 ;FOR MCSP SIZE
SKIPE SIMPSW ;IF SIMPLE
HRRZI PNT2,0 ;THEN NO MSCP
MOVEM PNT2,CSPOS ;SET CNTR
AL1: SETZM FIRSYM
SETZM LSTSYM
MOVEI TBITS2,SET!LSTBIT ;ALLOCATE SETS FIRST AMONG "ARITHMETICS"
PUSHJ P,ALLO
HRLZM PNT2,LLOCAL ;FOR SETS ONLY.
MOVEM A,LLIMS
MOVEM PNT2,ALOCAL ;START LOCAL COUNT FOR ARITHS.
MOVSI TBITS2,SBSCRP ;ALLOCATE ARRAYS.
PUSHJ P,ALLO
ADDM PNT2,ALOCAL ;COUNT OF ARITH. LOCALS.
MOVEI TBITS2,-1 ≠ (STRING!LSTBIT!SET) ;ALL OTHERS.
PUSHJ P,ALLO
ADDM PNT2,ALOCAL ;AND UPDATE LOCAL COUNT
PUSHJ P,TMPALO ;ALLOCATE TEMPS.
ADDM PNT2,ALOCAL ;AND UPDATE LOCAL COUNT
MOVE A,FIRSYM
HRL A,LSTSYM
MOVEM A,ALIMS ;LIMITS OF ARITH. LOCALS.
MOVE PNT2,CSPOS ;PICK UP STACK LOC
MOVEM PNT2,ASDIS ;SAVE IT AS ARITH STACK DISPL FOR LOCALS
REN <
PUSHJ P,HISET ;BACK TO CODE SEGMENT
>;REN
TLNN FF,ALLOCT ;ACTUALLY ALLOCATING ?
POPJ P, ;NO -- DONE COMPLETELY.
HRRZ PNT2,TPROC ;THIS PROCEDURE
SKIPN SIMPSW ;IF SIMPLE, NO PD
PUSHJ P,PDOUT ;PUT OUT PROC DESC
AL2: SETZM TTEMP ;RESTART TEMP LIST.
SETZM BLKCNT ;NO BLOCKS LOOKED AT OR ALLOCATED
QBEGIN (BLKIDX) ;FIND BOTTOM ELEMENT IN BLKLIM QSTACK
JUMPE B,CRECHK ; NO SYMBOLS TO ALLOCATE
Comment ⊗
; NOW ISSUE SYMBOLS FOR THIS PROCEDURE
At procedure declaration, and at the beginning of each NAMED block or
compound statement, a count called NMLVL (name level) is incremented. Its
current value is stored in $VAL2 of every block and NAMED compound
statement. It is also stored in procedure blocks. It is decremented at
appropriate times.
When a block pointer is placed in BLKLIS (via BLKIDX QPDP), its left half
is 0 if the block has a name, -1 otherwise (depends on higher-LEVELed block
for name). A non-named block's NMLVL should be the same as that of the
next named block in the list.
Inner blocks appear in BLKLIS preceding outer ones. DDT (as it happens)
requires that symbols for inner blocks appear first. So the algorithm for
symbol allocation is:
1) Search from BLKLIS bottom to 1st named Block (index→SBITS2)
2) Put out Block name and level to .REL file
3) NMLVL of this block to TBITS2
4) For each BLKLIS entry from current backwards to bottom,
or until an entry is found whose NMLVL is lower (outer block)
that TBITS2, if the Block hasn't been handled (list entry 0),
include its symbols in this DDT block on the .REL file.
5) Search forwards for the next named block (index → SBITS2).
If one is found, go to step 2.
6) If some blocks were not handled, it is because the outer block of
this procedure was not named. Put out procedure name as block name,
and repeat step 3 once more to get the rest of the symbols.
7) Reset BLKIDX QPDP
⊗
;STEP 1,5 -- FORWARDS SEARCH LOOP
DOSYM: MOVEM B,SBITS2 ;B GETS CHANGED BY DOSYL1
DOSYML: MOVE B,SBITS2 ;GET QSTACK PDP FOR FORWARD SEARCH
QTAKE (BLKIDX) ;LOOK AT NEXT BLOCK
JRST DIDSYM ; HAVE LOOKED AT ALL, CHECK FOR REMAINING
AOS BLKCNT ;ADD ONE FOR EACH ONE GLIMPSED
MOVEM B,SBITS2 ;PROTECT THIS QPDP
JUMPLE A,DOSYML ;IF NOT NAMED, CONTINUE FORWARD SEARCH
MOVE LPSA,A
;STEP 2
PUSHJ P,BLBOUT ;ISSUE BLOCK NAME TO .REL FILE
;STEP 3
HRRZ TBITS2,$VAL2(LPSA) ;NMLVL (DDT LEVEL) OF THIS BLOCK
MOVE B,SBITS2 ;BLBOUT CHANGES, MAYBE
;STEP4 -- BACKWARDS SEARCH LOOP
DOSYL1: QBACK ;NONDESTRUCTIVE POP
JRST DOSYML ; HAVE ALL BLOCKS, RETURN TO FORWARD SEARCH
JUMPE A,DOSYL1 ;ALREADY DID THIS ONE
MOVE LPSA,A ;BELONGS HERE FOR NOSY ETC.
HRRZ TEMP,$VAL2(LPSA);NMLVL OF THIS BLOCK
CAMLE TBITS2,TEMP ;IF NEW LEVEL LOWER, DON'T INCLUDE IT,
JRST DOSYML ; RETURN TO FORWARD SEARCH
HLRZ TEMP,B ;GET CURRENT "QSTACK" POINTER
SETZM 1(TEMP) ;ZERO "POPPED" ENTRY
SOS BLKCNT ;SUBTRACT ONE FOR EACH ONE ALLOCATED
PUSH P,%TLINK(LPSA) ;
PUSH P,B
PUSHJ P,NOSY ;ALLOCATE SYMBOLS FOR THIS BLOCK
POP P,B
POP P,LPSA ;SEE IF HAD A SECOND SEMBLK
TLNN LPSA,-1 ;IF NOT
JRST DOSYL1 ;CONTINUE BACKWARDS SEARCH
HLRZ LPSA,LPSA ;WE DID
FREBLK ;DONE WITH IT NOW
JRST DOSYL1 ;CONTINUE BACKWARDS
;STEP 6 -- PUT OUT PROCNAME BLOCK IF NOT ALL GONE
DIDSYM: SKIPG BLKCNT ;DID WE SEE SOME WE DIDN'T ALLOCATE?
JRST DIDALL ; NO, ALL DONE
SETOM BLKCNT ;WON'T FAIL AGAIN
MOVE LPSA,TPROC ;USE PROCEDURE NAME AS OUTER BLOCK NAME
PUSHJ P,BLBOUT
MOVNI TBITS2,1 ;VERRRY LOW LEVEL
MOVE B,BLKIDX ;LOOK AT ALL POSSIBLE ENTRIES
JRST DOSYL1 ;GO ROUND ONCE MORE, GET THE REST
;STEP 7 -- CLEAN UP
DIDALL: QFLUSH (BLKIDX) ;RELEASE STORAGE, CLEAR QPDP
SKIPE SIMPSW ;NO PD FOR SIMPLE
JRST CRECHK ;
CRECHK:
TLNN FF,CREFSW ;IF ¬CREFFING, DONE.
POPJ P, ;DONE
MOVE LPSA,TPROC ;PROCEDURE NAME
CAIE LPSA,RESYM ;NOT THIS ONE;
JRST CREFBLOCK ;FOR BLOCK EXIT.
APOPJ: POPJ P,
NOSY: PUSHJ P,URGSTR ;IF ON STRING RING....
FREBLK ;DELETE THE BLOCK.
RIGHT ,%RVARB,APOPJ ;GO TO NEXT BLOCK.(OR POPJ)
SY2A: MOVE TBITS,$TBITS(LPSA)
TLNE FF,CREFSW ;IF CREFFING.
PUSHJ P,CREFDEF ;DEFINE THE SYMBOL.
TLNE TBITS,RES ;IF RESERVED WORD (NEW DEF),
JRST NOSY ; (VIA LET) , FORGET IT
TLNE TBITS,SBSCRP ;TURN OFF STRING IF ARRAY
TRZ TBITS,STRING
PUSHJ P,RAD50 ;MAKE SURE A SYMBOL NAME GETS MADE
TRNE TBITS,ITEM
TLNE TBITS,FORMAL!SBSCRP!EXTRNL ;PUT OUT ITEM NUMBER IF
JRST NOITMS ;IT IS THERE.
HRRZ TEMP,$VAL2(LPSA) ;POINTER TO INTEGER.
MOVE B,$VAL(TEMP) ;ITEM NUMBER.
;; # # BY JRL (1-25-73)
CAMGE B,[20]
TLO A,400000 ;HALF KILL ITEM NO. < 20
;; # #
PUSHJ P,SCOUT0 ;NO RELOCATION.
JRST NOSY
NOITMS: HRRZ B,$ADR(LPSA) ;FIXUP
;;#KY# ALLOW GLOBAL INTERNAL SYMBOLS OUT (FIX 1 OF 2)
TRNE TBITS,GLOBL ;
TLNN TBITS,INTRNL ;
;;#KY# 1 OF 2
JUMPE B,NOSY1 ;NO SYMBOL
GLOC <
TRNE TBITS,GLOBL ;IF NOT GLOBAL
TRNE TBITS,ITEM ;OR IT ITEM, THEN
JRST REGSYM ;NOT POSSIBLY A GLOBAL TYPE.
HRLZ B,$ADR(LPSA) ;FIXUP CHAIN
HLR B,$VAL2(LPSA) ; AND THE GLOBAL NUMBER.
ADDI B,400013 ; GLOBAL DATA BASE.
HRRM B,$ADR(LPSA) ;FOR THE SYMBOL....
;;#KY# ↓ 2 OF 2
TLNE B,-1 ;ANY TO FIX UP?
PUSHJ P,FIXOUT ;FIXUP WITH NO RELOCATION.
PUSHJ P,SCOUT0 ;PUT OUT SYMBOL WITH NO RELOC.
JRST NOSY
REGSYM:
>;GLOC
;;#II#↓ 7-4-72 DCS DON'T LET DEFINES OUT!
TLNN TBITS,DEFINE
PUSHJ P,SOUT ;OUTPUT THE SYMBOL.
TRC TBITS,FORWRD!LABEL
TRCN TBITS,FORWRD!LABEL ;HAS A LABEL BEEN USED BUT NOT DEFINED?
ERR <UNUSED LABEL: >,3
NOSY1: TRNE TBITS,PROCED
JRST PPR ;PROCEDURE AND FRIENDS.
TLNN TBITS,DEFINE ;DELETE THE MACRO BODY ....
JRST CHARYZ ;CHECK ARRAYS.
PUSH P,LPSA
LEFT ,%TLINK,LPSERR
PUSHJ P,REMOPL ;UNLINK MACRO BODY.
POP P,LPSA
JRST NOSY ;ALL DONE
CHARYZ: TLNN TBITS,SBSCRP ;ARRAY?
JRST CHKTWO ; NO
PUSH P,LPSA
HRRZ B,$VAL(LPSA) ;ARRAY ADDRESS IF OWN ARRAY
MOVE A,RAD5. ;DOTTED SYMBOL NAME
TLZ A,740000 ;MAKE AN INTERNAL SYMBOL!
TLO A,100000 ;LIKE THIS
TLNE TBITS,OWN ;BUILT IN?
PUSHJ P,SCOUT ; YES, PUT OUT A SYMBOL
LEFT ,%TLINK,NOBBLK ;DELETE BNDBLK (SEE ARRAY)
FREBLK
NOBBLK: POP P,LPSA ; IF THERE IS ONE
CHKTWO: TLNE TBITS,INTRNL!EXTRNL ;IS THERE
TRNN TBITS,STRING ;A SECOND SYMBOL?
JRST NOSY ;NO -- DONE
MOVE A,RAD5. ;GET KLUDGED UP VERSION OF SYMBOL
HLRZ B,$ADR(LPSA) ;GET ADDRESS FOR 2D WORD
JUMPE B,NOSY ;AN EXTERNAL STRING COULD CAUSE THIS
PUSHJ P,SCOUT ;OUTPUT SYMBOL
JRST NOSY
PPR: TLNE TBITS,EXTRNL!MESSAGE ;DON'T MAKE THIS CHECK FOR EXTERNALS
JRST PPR1
TRNE TBITS,FORWRD ;CHECK FOR FORWARD NEVER DEFINED
ERR <FORWARD PROCEDURE NEVER DEFINED: >,3
PPR1: PUSH P,LPSA
LEFT ,%TLINK,LPSERR ;LPSA → 2D PROC BLOCK
MOVE A,LPSA ;SAVE POINTER
LEFT (,%TLINK,PPR4) ;→FIRST PARAM OR NIL
PPR2:
COMMENT ⊗THIS COMMENT FLUSHES A POTENTIAL BUG
BUT STILL LEAVES EVIL AROUND, IN THE FORM OF WASTED SPACE
HRRZ B,$VAL2(LPSA) ;DOET THIS HAVE A DEFAULT VALUE
JUMPE B,PPRX ;NO
HRRZ C,$ADR(B) ;ZERO FIXUP ?
JUMPN C,PPRX ;NO?
EXCH B,LPSA ;
FREBLK ;GET RID OF IT
SKIPA LPSA,B ;LPSA ← FORMAL SEMBLK
⊗
PPRX: MOVE B,LPSA ;SAVE IT
;;#MC# ↓ NEED TO GET IT OFF STRING RING TOO RHT 4-20-73
PUSHJ P,URGSTR ;GET OFF THE STRING RING
FREBLK ;KILL IT
RIGHT (B,%RVARB,PPR4) ;GET NEXT
JRST PPR2
PPR4:
FREBLK (A) ;DELETE 2D PROC BLOCK
;THE FOLLOWING CODE HANDLES THE PROCEDURE DESCRIPTOR
MOVE LPSA,(P) ;PICK UP PROCEDURE
HRRZ A,$VAL(LPSA) ;PICK UP THE PD SEMBLK
JUMPE A,NOPD
TLNN TBITS,EXTRNL ;EXTERNAL?
JRST NOEXPD ;NO
SKIPGE C,$ADR(A) ;OUT ALREADY??
ERR <DRYROT AT NOSY --EXTERNAL PD >,1
TRNN C,-1 ;FIXUPS??
JRST PDFDON ;NO
PUSH P,B
PUSH P,A
HRLM C,PDFFHD ;REMEMBER FIXUP HEAD
PUSHJ P,RAD50 ;GET PROCEDURE RADIX50
TLC A,640000 ;CHANGE TYPE BITS
HLRM A,R5PD1 ;SAVE RADIX50 IN BLOCK
;;#KM# RHT ↓ 11-24-72 "B"→→ "A"
HRLM A,R5PD2
MOVE B,PDPFBD ;POLISH FIXUP BLOCK DESC
PUSHJ P,FRBT ;FLUSH BN OUTPUT
PUSHJ P,GBOUT ;PUT OUT THE BLOCK
POP P,A
POP P,B
JRST PDFDON
NOEXPD:
;;#IV# RHT (9-22-72) IGNORE FORWARD PROCEDURES HERE
TRNE TBITS,FORWRD
JRST PDFDON
;;#IV#
PUSH P,A
PUSHJ P,RAD50 ;GET RADIX 50 SYMBOL
MOVE A,RAD5$ ;THE $ SYMBOL
TLZ A,740000
TLO A,100000 ;LOCAL PROCEDURE
HRRZ B,$VAL(LPSA)
SKIPL B,$ADR(B) ;THE ADDRESS
ERR <DRYROT AT NOSY -- NON EXTERNAL PROC>
PUSHJ P,SCOUT ;PUT PD SYMBOL OUT
POP P,A ;
PDFDON: HLRZ C,%TLINK(A) ;POINT AT PDA,,0 SEMBLK
FREBLK (A) ;FREE PD BLOCK
JUMPE C,NOPD ;FREE PDA,,0 BLOCK IF HAVE ONE
FREBLK (C)
NOPD:
POP P,LPSA
GLOC <
;;#JF# RHT (9-27-72) ↓ BE SURE MESSAGE BLOCK GETS RIGHT ADDR
HRRZ B,$ADR(LPSA) ;
CAIE B,0 ;IF FORWARD MESSAGE DESCRIP. NEVER DEFINED
TLNN TBITS,MESSAGE ;AND IS DEFINITELY A MESSAGE
JRST NOSY ; --
TLO FF,RELOC ;FIRST GOES THE WORD WHICH CHAINS LINKS.
HRRO A,PCNT
EXCH A,MESLNK ;MESSAGE LINK
PUSHJ P,CODOUT ;PUT IT OUT
HRL A,$PNAME(LPSA) ;STRING COUNT
HRR A,B ;ADDRESS OF PROCEDURE
TLO FF,RELOC ;AGAIN SINCE IF MESLNK WAS ZERO, OUR FRIEND
;CODOUT RESET RELOC.......
PUSHJ P,CODOUT ;XWD #CHARS,,PROD ADDRESS.
TLZ FF,RELOC
HRRZ C,$PNAME(LPSA) ;#CHARS AGAIN.
ADDI C,4 ;..
IDIVI C,=5
MES21: AOS B,$PNAME+1(LPSA);WE CAN HAPPILY DESTROY THE BYTE POINTER.
MOVE A,-1(B) ;FIRST WORD OF PNAMES.
PUSHJ P,CODOUT ;OUT IT GOES.
MOVE A,(B) ;NEXT WORD
CAIGE C,2 ;...
MOVEI A,0 ;NOT TWO WORDS LONG.
PUSHJ P,CODOUT
>;GLOC
JRST NOSY ;AND LOOP.
;LOADER BLOCK FOR POLISH FIXUP
LODBLK(,11,PDPFB,PDPFBD,5,,<XWD 001000,0>)
RELOC .-5
XWD 3,1 ;ADD , LITC
-1
R5PD1: XWD 2,0 ;OPDC ,, LH OF RAD50
R5PD2: XWD 0,-1 ;RH OF RAD50,,SHR
PDFFHD: XWD 0,0 ;DEST ,,0
DSCR BLBOUT
CAL PUSHJ
PAR LPSA is Semantics of Block with a name
DES outputs a Block name LOADER block via GBOUT. Saves RADIX50 for
name, and SHOUT makes sure that no two consecutive blocks output
with the same names. This can happen: PRODEDURE FINIS (..);
BEGIN "FINIS" ... two identical block names
cause havoc with DDT.
SID Uses most ACs except SBITS, PNT2 group
⊗
BLBOUT:
MOVE TBITS,$TBITS(LPSA) ;SEE IF IT IS A PROCEDURE OR NOT
HRRZ B,$VAL2(LPSA) ;LEVEL (DDT) OF THIS BLOCK
TRNN TBITS,PROCED ;IF PROCEDURE,
; GET LEVEL FROM DIFFERENT PLACE
JRST NOPRCC
HLRZ TEMP,%TLINK(LPSA)
HRRZ B,$VAL2(TEMP)
NOPRCC: PUSHJ P,RAD50 ;GET BLOCK NAME IN RADIX50
TLZ A,740000 ;CLEAR SYMBOL TYPE BITS
TLO A,140000 ;PUT IN THE RIGHT ONES
PUSHJ P,SCOUT ;PUT OUT BLOCK NAME
MOVEM A,LSTRAD ;SAVE RADIX50 FOR THE BLOCK NAME.
TRNE TBITS,PROCED
POPJ P,
MOVE A,RAD5.
TLZ A,740000 ;SHOULD BE BLOCK TYPE 10
TLO A,100000
HLRZ B,$VAL2(LPSA)
PPFF: JRST SCOUT ;MAKE LABEL FOR BLK OR CMPD STMT.
DSCR PDOUT
DES ROUTINE TO OUTPUT THE PROCEDURE DESCRIPTOR -- USED ONLY FOR DISPLAY SYSTEMS
PARM PROC SEMBLK ADDRESS IN PNT2
SID ALL ACCUMULATORS SAVED EXCEPT TEMP & LPSA
⊗
BITDATA( PROC DESC STUFF)
BLKCOD←←17 ;BLOCK BOUNDARY CODE
EOPCOD←←0 ;END OF PROC LVI CODE
AACOD←←1 ;ARITH ARRAY
SACOD←←2 ;STRING ARRAY
SETCOD←←3 ;SET
LACOD←←4 ;LIST OR SET ARRAY
FRCCOD←←5 ;FOREACH STATEMENT
KLCOD←←6 ;KILL LIST
CTXCOD ←← 7 ;CONTEXT
CLNCOD ←← 10 ;CLEANUP PROC
ENDDATA
PDOUT: PUSH P,FF ;SAVE FF
PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,SBITS2
PUSH P,TBITS
PUSH P,PNT
HRRZ PNT,$VAL(PNT2) ;PICK UP PD SEMBLK
JUMPE PNT,XPDOUT ;IF OUTER BLOCK, NOTHING GOES OUT
MOVEI A,0
TLZ FF,RELOC
PUSHJ P,CODOUT
MOVEI B,%PDLNK ;LINK THE PROC DESC
PUSHJ P,LNKOUT
HRRZ B,PCNT ;THE CURRENT ADDRESS
HRL B,$ADR(PNT) ;FIXUP REFERENCES TO PDA
HRROM B,$ADR(PNT) ;REMEMBER THE FACT THAT PDA IS RIGHT
TLNE B,-1 ;IF THERE WERE ANY
PUSHJ P,FBOUT ;DO IT
HRRZ A,$ADR(PNT2) ;ADDRESS OF PROC ENTRY
TLO FF,RELOC
PUSHJ P,CODOUT
HRRZ A,$PNAME(PNT2) ;LENGTH OF THE NAME
TLZ FF,RELOC
PUSHJ P,CODOUT ;PUT IT OUT
HRRZ B,PCNT
HRRM B,$PNAME+1(PNT) ;REMEMBER THIS SPOT
MOVE A,[POINT 7,0] ;BYTE PTR WORD FOR PNAME
PUSHJ P,CODOUT
MOVEI B,PROCB
MOVE A,$TBITS(PNT2)
TRNE A,ITEM!ITMVAR
TRO B,ITEMB
TLNE A,MPBIND ;MATCHING PROC?
TRO B,BINDB ;YEP
PUSHJ P,ITMTYP ;SIX BIT TYPE
LSH A,5 ;INTO ITS SPOT
TLO A,(B) ;OTHER BITS
;;%AA% A NEW FEATURE RHT -- SPROUT DEFAULTS 9-1-73
HLR A,$VAL(PNT2) ;ADD IN SPROUT DEFAULTS
PUSHJ P,CODOUT ;PUT OUT PROCEDURE TYPE
HLRZ B,%TLINK(PNT2) ;POINT AT 2ND PROC SEMBLK
MOVS A,$NPRMS(B) ;#SPARMS*2,,#APRMS +1 →→ A
PUSHJ P,CODOUT ;PUT IT OUT
HRL A,SSDIS ;+SS DISP
HRR A,ASDIS ;+AS DISP
PUSHJ P,CODOUT ;
LLPUT: HRLZ A,$SBITS(PNT2)
AND A,[XWD LLFLDM,0] ;LEX LEV
HRR A,$VAL2(PNT) ;LVI FIXUP
HRL B,PCNT
HLRM B,$VAL2(PNT)
TLO FF,RELOC
PUSHJ P,CODOUT
DLPUT: HRLZ A,CDLEV ;CURRENT DISPLAY LEVEL
HRR A,$VAL(PNT) ;PARAM INFO FIXUP
HRL B,PCNT ;
HLRM B,$VAL(PNT)
TLO FF,RELOC
PUSHJ P,CODOUT
HLRZ B,%TLINK(PNT) ;POINT AT [PDA,,0] SEMBLK
CAIN B,0 ;DO WE HAVE ONE
JRST PDAX0 ;NO
HRL B,$ADR(B)
HRR B,PCNT ;HERE IT IS
TLNE B,-1
PUSHJ P,FBOUT
PDAX0: HRLZ A,$ADR(PNT) ;PICK UP PDA INTO LH
PUSHJ P,CODLRL ;GO RELOCATE LH
HLRZ C,%TLINK(PNT2) ;LOOK AT 2ND PROC SEMBLK
HRRZ C,%SAVET(C) ;TO FIND PARENT PROC
MOVEI A,0 ;
JUMPE C,[ TLZ FF,RELOC ;IF THE TOP LEVEL (I.E. NO DADDY)
PUSHJ P,CODOUT ;PUT OUT THE 0
JRST PCPRD] ;GO ON TO NEXT THING
HRRZ C,$VAL(C) ;PD SEMBLK
HRRZ A,$ADR(C) ;EASIEST TO CHAIN BY SELF
HRR B,PCNT ;NEW CHAIN
HRRM B,$ADR(C)
HLL A,$ACNO(PNT) ;PCNT AT END OF MKSEMT
PPDA0: TLO FF,RELOC
PUSHJ P,CODLRL ;GO PUT IT OUT
PCPRD: MOVE A,$ACNO(PNT2) ;PCNT AT PRDEC,,EXIT(FIXED UP)
HRR A,$ACNO(PNT) ;PICK UP EXIT FROM PD SEMBLK
TLO FF,RELOC
PUSHJ P,CODLRL ;RELOC BOTH HALVES
HLRZ C,%TLINK(PNT2) ;SECOND PROC SEMBLK
HLRZ C,%SAVET(C) ;OLD TTOP
HRLZ A,PCNT ;
HLR A,$SBITS(C) ;FIXUP LVI REF TO PARENT BLOCK
HLLM A,$SBITS(C) ;FIXUP CONTINUED
HRRZS A ;SCRATCH THE OLD CRUFT
PUSHJ P,CODOUT ;PUT IT OUT
TLZ FF,RELOC
HLRZ LPSA,%TLINK(PNT2) ;LPSA← →→ 2ND PROC SEMBLK
HLRZ LPSA,%TLINK(LPSA) ;LPSA NOW →→ FIRST PARA
JUMPE LPSA,DOLVIN ;THERE MAY NOT BE ANY
HRR B,PCNT
HRL B,$VAL(PNT) ;LOC OF START OF PROC PARAM INFO
PUSHJ P,FBOUT
NPTB: MOVE A,$TBITS(LPSA) ;PICK IT UP
MOVEI B,
TRNN A,ITEM!ITMVAR ;ITEMISH ?
JRST NTITFP ;NO
TRO B,ITEMB ;YES
TLCE A,SBSCRP ;TEST THE ARY2 THING
TROA B,ARY2B ;
TLC A,SBSCRP ;
TLNE A,MPBIND ;BINDING ITEMVAR
TRO B,QUESB ;SAY SO
NTITFP: TLNE A,REFRNC ;REFERENCE??
TRO B,REFB ;THE REF BIT
TRNE A,PROCED ;PROCEDURE
TRO B,PROCB ;GET TYPE
PUSHJ P,ITMTYP ;
LSH A,5 ;LEFT 5 TO GET OUT OF FULL ADDR
TRO A,(B) ;THE OTHER BITS
HRLZ A,A ;THE OTHER HALF!
PUSHJ P,CODOUT ;PUT IT OUT
RIGHT ,%RVARB,DOLVIN
JRST NPTB ;GO DO NEXT ONE
DOLVIN: PUSH P,PNT2
HRR B,PCNT
HRL B,$VAL2(PNT)
PUSHJ P,FBOUT
MOVE PNT,$SBITS(PNT2)
ANDI PNT,LLFLDM ;LEX LEVEL
SKIPE SBITS2,BLKIDX ;PICK UP
PUSHJ P,LVIOUT
POP P,PNT2
TLZ FF,RELOC
MOVEI A,0
PUSHJ P,CODOUT ;PUT OUT END OF LVI FLAG
MOVE PNT,$VAL(PNT2) ;PD SEMBLK AGAIN
HRL B,$PNAME+1(PNT) ;FIX UP THE STRING REFERENCE
HRR B,PCNT
PUSHJ P,FBOUT
HRRZ SBITS2,$PNAME(PNT2) ;LEN OF PNAME
TLZ FF,RELOC ;DO NOT RELOCATE
MOVE LPSA,$PNAME+1(PNT2) ;BYTE PTR FOR PNAME
TRDY: MOVE TEMP,[POINT 7,A]
MOVEI A,0
MOVEI B,5
TPNC: SOJL SBITS2,PNMDN
ILDB C,LPSA ;PICK UP CHAR
IDPB C,TEMP ;PUT IT DOWN
SOJG B,TPNC
PUSHJ P,CODOUT
JRST TRDY
PNMDN: CAIE B,5
PUSHJ P,CODOUT
XPDOUT: POP P,PNT ;RETURN
POP P,TBITS
POP P,SBITS2
POP P,C
POP P,B
POP P,A
POP P,FF
POPJ P,
;ROUTINE TO PUT OUT LOCAL VAR INFO -- USED BY DIS
;PARAMS -- BLOCK QPDP IN SBITS2,, LEX LEV IN PNT
LVIOUT: PUSH P,[-1] ;CLEVER FLAG TO CATCH BIG PARENT
LVIO.1: MOVE B,SBITS2
QBACK
JRST LVIEXT ;ALL DONE
MOVEM B,SBITS2
MOVE PNT2,A ;GET HIS NAME
LDB PNT,[POINT LLFLDL,$SBITS(PNT2),=35]
HRRZ B,PCNT
HLL B,$SBITS(PNT2)
TLNE B,-1
PUSHJ P,FBOUT ;FIXUP REFS FOR THIS BLOCK'S INFO, IF ANY
HRLM B,$SBITS(PNT2) ;REMEMBER MY SPOT
HLRZ LPSA,%TLINK(PNT2) ;SECOND PROC SEMBLK
JUMPE LPSA,LIT.1 ;NONE
SKIPN $ACNO(LPSA) ;THE QPDP FOR CLEANUPS
JRST LIT.1 ;NONE
QBEGIN (<$ACNO(LPSA)>) ;GET INITIAL QPDP
LIT.0: QTAKE ;TAKE ONE
JRST LIT.X ;DONE
MOVE TBITS,$TBITS(A) ;GET TYPE
MOVE C,A ;
HRRZ A,$ADR(C) ;ADDRESS
TDNN TBITS,[XWD EXTRNL,FORWRD+INPROG] ;NEED FIXUP?
JRST LIT.01 ;NO
HRL C,PCNT ;YES
HLRM C,$ADR(C) ;
LIT.01: HRLI A,CLNCOD⊗=14 ;TYPE IS CLEANUP
DPB PNT,[ POINT =9,A,=12] ;LEX LEV
TLO FF,RELOC ;RELOC
PUSHJ P,CODOUT ;
JRST LIT.0 ;GET NEXT
LIT.X: QFLUSH
LIT.1: MOVE LPSA,PNT2
LITER: RIGHT ,%RVARB,EBK ;GO DOWN VARB RING
MOVE TBITS,$TBITS(LPSA) ;PICK UP TYPE BITS
;;#IT# RHT 8-4-72 ↓ KEEP OUT EXTERNALS
;;#IZ# RHT 9-25-72 ↓ ALSO KEEP OUT GLOBALS
TDNE TBITS,[XWD EXTRNL!OWN,GLOBL!PROCED];OWN STUFF NEVER GOES,
; ALSO NO PROCS OR EXTERNALS
JRST LITER
TLNE TBITS,SBSCRP
JRST ARYINF
;;# # DCS 5-3-72 SETS, BUT NOT SET ITEMS!!
TRNE TBITS,ITMVAR!ITEM ;CHECK IT OUT -- DCS
JRST LITER ;LOOP
;;# # 5-3
TRNE TBITS,SET ;SET??
JRST SETINF
TRNE TBITS,INTEGR ;TEST FOR THE FOREACH KLUGE (FLOATING INTEGER)
TRNN TBITS,FLOTNG
JRST LITER ;LOOP
FRCINF: MOVEI B,FRCCOD ;FOREACH CODE
JRST PUTCI
ARYINF: TLNE TBITS,BILTIN ;BUILT IN
JRST LITER ;YES,DONT BOTHER
MOVEI B,AACOD ;ARITH CODE
TRNE TBITS,STRING ;MAYBE IT WAS A STRING ARRAY
MOVEI B,SACOD
TRNE TBITS,SET ;OR A LEAPISH THING
MOVEI B,LACOD
JRST PUTCI
;;# # RHT 8-1-72 KILL SET
SETINF: TLNN TBITS,SAFE ;CHECK IF KILL SET
JRST SETI.1 ;NO
TRNN TBITS,INTEGR ;BE SURE
ERR <DRYROT AT LVIOUT>
MOVEI B,KLCOD
JRST PUTCI
;;# # RHT 8-1-72
SETI.1: SKIPN RECSW
JRST LITER
MOVEI B,CTXCOD ;CONTEXT?
TRNE TBITS,FLOTNG ;CHECK
JRST PUTCI
MOVEI B,SETCOD
PUTCI: MOVEI A,0
SKIPE RECSW ;IS THIS FORB RECURSIVE??
HRLZI A,RF
DPB B,[POINT 4,A,3]
DPB PNT,[POINT =9,A,=12]
TLO FF,RELOC
SKIPE RECSW
TLZ FF,RELOC
HRR A,$ADR(LPSA)
TRNE A,-1 ;DID IT GET USED?? - IF SO MUST BE NON ZERO FOR
;EITHER CORE OR STACK (SINCE (F) IS DYN LINK)
PUSHJ P,CODOUT
JRST LITER
EBK: HRLZ A,PNT
LSH A,5 ;PUT LEX LEV IN RIGHT SPOT
MOVEI B,BLKCOD ;SAY IT IS A BLOCK
DPB B,[POINT 4,A,3]
AOSN (P) ;IS THIS THE OUTER BLK FOR THIS PD
JRST .+4 ;YES LINK UP IS ZERO
HLRZ B,$ADR(PNT2) ;
HLR A,$SBITS(B) ;RH OF A ←← PARENT'S LVI AREA
TLOA FF,RELOC ;
TLZ FF,RELOC ;NEVER RELOC 0
PUSHJ P,CODOUT ;PUT OUT FLAG WORD
JRST LVIO.1 ;GO GET NEXT BLOCK
LVIEXT: SUB P,[XWD 2,2] ;FLUSH THE FLAG
JRST @1(P) ;RETURN
;; %AA% -- SDFLTS
↑SDFLTS:
MOVE PNT,GENLEF+1;
PUSHJ P,GETAD; BETTER HAVE AN INTEGER CONSTANT
TRNN TBITS,INTEGR
ERR <YOU NEED AN INTEGER CONSTANT HERE>,1,CPOPJ
MOVE A,$VAL(PNT)
LSH A,-4 ;THE VALUE SHIFTED TO GET RID OF CONTROL OPTS
SKIPE SIMPSW ;MAY NOT BE SIMPLE
ERR <YOU CANNOT DO THIS INSIDE A SIMPLE PROCEDURE>,1,CPOPJ
MOVE PNT2,TPROC ;THE CURRENT PROCEDURE
HRLM A,$VAL(PNT2) ;SAVE IT AWAY
;;#OB# RHT ↓ 10-31-73 NEED TO SETZM BITS
JRST CLRSET ;DONE
COMMENT ⊗Allo -- Allocate One Type of Symbol
ALLO looks at each symbol and outputs its core locations, etc.
It also outputs fixups, and saves the final core address in
$ADR so that the symbol-outputter can find it.
⊗
ALLO: MOVEI PNT2,0 ;COUNT OF LOCALS ALLOCATED.
SKIPN SBITS2,BLKIDX ;GET QPDP FOR BLOCK QSTACK
JRST CPOPJ ; NOTHING TO ALLOCATE
ITE: MOVE B,SBITS2 ;GET QPDP TO PARAM POSITION
QBACK ;NON-DESTRUCTIVE QPOP
JRST [HRR A,FIRSYM ;SET UP ALIMS-TYPE WORD
HRL A,LSTSYM
POPJ P,] ;DONE
MOVEM B,SBITS2 ;SAVE UPDATED QPDP
MOVE LPSA,A
ITER: RIGHT ,%RVARB,ITE ;GO DOWN LIST
MOVE TBITS,$TBITS(LPSA) ;TYPE BITS.
TRNE TBITS,SET ;IF A SET DO NOT ALLOCATE AS ARITH TOO
TRZ TBITS,FLOTNG!INTEGR
TLNE TBITS,SBSCRP ;DO NOT ALLOCATE AS BOTH ARRAY AND INTEGER!!!
TRZ TBITS,STRING!INTEGR!FLOTNG!ITMVAR!ITEM!SET!LSTBIT!LPARRAY!SHORT
TRNE TBITS,ITEM!ITMVAR
TRZ TBITS,STRING!INTEGR!FLOTNG!SET!LSTBIT
TRNN TBITS,PROCED!LABEL ;NEVER SPACE FOR THESE.
TDNN TBITS,TBITS2 ;USE THE MASK.
JRST ITER ;NO MATCH -- GO FARTHER
ALOWDS:
TDNE TBITS,[XWD EXTRNL!DEFINE,GLOBL] ;PUT OUT NO CODE
; OR FIXUPS FOR EXTERNALS
JRST ITER
TLNE TBITS,SBSCRP ;ALWAYS ALLOCATE ARRAYS
JRST ANYWAY
SKIPN B,$ADR(LPSA) ;IF $ADR IS 0 AND SYMBOL IS NOT
TLNN TBITS,INTRNL ; INTERNAL, DON'T PUT OUT CODE OR FIXUPS
JUMPE B,ITER
ANYWAY:
SKIPE RECSW ;IF NOT RECURSIVE
TDNE TBITS,[XWD OWN,ITEM] ;OR VAR IS OWN, ITEM OR THE LIKE
JRST ALCV ;IT GETS INTO CORE
AOS B,CSPOS ;USE A STACK LOCN
TLNN FF,ALLOCT ;ALLOCATING?
JRST [TRNE TBITS,STRING ;NO-- IS IT A STRING?
AOS CSPOS ;YES
JRST ITER]
HRL B,$ADR(LPSA) ;FIRST FIXUP
HRRM B,$ADR(LPSA) ;SAVE ITS SACK INC
TLNE B,-1 ;MIGHT BE UNUSED
PUSHJ P,FIXOUT ;NO RELOC FOR FIXED UP VALUE
TRNN TBITS,STRING ;STRING????
JRST ITER ;NO -- DONE WITH THIS
AOS B,CSPOS ;BUMP STACK DISPL
HLL B,$ADR(LPSA) ;SECOND WORD FIXUP CHAIN
HRLM B,$ADR(LPSA) ;SAVE IT
TLNE B,-1 ;USED?
PUSHJ P,FIXOUT ;YES
JRST ITER ;AT LAST
ALCV:
MOVEM LPSA,LSTSYM ;LAST SYMBOL
AOS PNT2 ;INCREMENT COUNT.
SKIPN FIRSYM
MOVEM LPSA,FIRSYM ;RECORD FIRST SYMBOL ONCE!!
TLNN FF,ALLOCT ;ACTUALLY ALLOCATE?
JRST ITER ;NO -- LOOP
HRLZ B,$ADR(LPSA) ;FIRST FIXUP
HRR B,PCNT
HRRM B,$ADR(LPSA) ;SAVE THE PCNT FOR SOUT TO FIND.
TLNE B,-1 ;IN CASE A STRING WHICH ONLY USES SECOND WD.
PUSHJ P,FBOUT ;OUTPUT THE FIXUP
; BUG TRAP -- $VAL SHOULD GENERALLY BE 0 THRU HERE
SKIPE A,$VAL(LPSA) ;VALUE WORD
TRNE TBITS,ITEM ;EXCEPT ITEMS.........
JRST NVL ; IT IS ZERO
TLNN TBITS,SBSCRP ;CAN BE NON-ZERO IF ARRAY
ERR <DRYROT -- ALLO>,1
NVL:
TLZ FF,RELOC
TLNE TBITS,SBSCRP ;WANT RELOCATABLE IF ARRAY
TLO FF,RELOC ; UNLESS IT IS ZERO
PUSHJ P,CODOUT ;OUTPUT A WORD FOR IT!
TLZ FF,RELOC ;MAKE SURE IT'S OFF
TRNN TBITS,STRING ;DO WE WANT STILL ANOTHER WORD?
JRST ITER ;NO -- LOOP
HLLZ B,$ADR(LPSA) ;SECOND FIXUP
HRR B,PCNT
HRLM B,$ADR(LPSA) ;SAVE THIS FOR 2D SYMBOL IF ANY
TLNE B,-1 ;IN CASE NOT USED.
PUSHJ P,FBOUT ;OUTPUT FIXUP
MOVEI A,0
PUSHJ P,CODOUT ;AND A WORD OF STORAGE.
JRST ITER ;LOOP
;ROUTINE TO ALLOCATE SPACE FOR TEMP CELLS AND TO OUTPUT
;FIXUPS.
TMPALO: SETZM PNT2 ;COUNT
HRRZ LPSA,TTEMP
JUMPE LPSA,CPOPJ
TMPAL: MOVE SBITS,$SBITS(LPSA) ;S BITS.
TLNN SBITS,CORTMP ;A CORE TEMP?
JRST TMNXT ;NO
MOVEM LPSA,LSTSYM ;SAVE
SKIPN FIRSYM ;NO ARITH VARIABLES?
MOVEM LPSA,FIRSYM ; THAT'S RIGHT, THIS TEMP IS FIRST
MOVEI TEMP,INTEGR ;MIGHT BE INDXED STRING TEMP LEFT OVER,
MOVEM TEMP,$TBITS(LPSA) ;THIS IS EASIEST WAY TO AVOID CONFUSION
;(PRUP CHECKS STRING, DOES FXTWO, WE DON'T
; WANT THAT HERE)
TLZ SBITS,INDXED!FIXARR ;DO SOME THINGS TO SBITS TOO
TLZE SBITS,INAC!PTRAC!STTEMP ;ONLY REMAINING USE IS
ERR <DRYROT -- TMPALL>,1 ; FOR REC. PROC BLT CODE
MOVEM SBITS,$SBITS(LPSA) ;(MORE HONESTY)
AOS PNT2
SKIPN RECSW ;IF NOT RECURSIVE
JRST ALCTMP ;THEY GO TO CORE
AOS B,CSPOS ;BUMP THE STACK OFFSET
TLNN FF,ALLOCT ;ACTUALLY ALLOCATE?
JRST TMNXT ;NO
HRL B,$ADR(LPSA) ;PICK UP FIXUP CHAIN
PUSHJ P,FIXOUT ;FIXUP
JRST TMNXT
ALCTMP:
TLNN FF,ALLOCT ;ACTUALLY ALLOCATE?
JRST TMNXT ;NO
HRR B,PCNT
HRL B,$ADR(LPSA)
PUSHJ P,FBOUT ;FIXUP
; PUT OUT A "TEMPXX" SYMBOL
MOVE A,$PNAME(LPSA) ;ID NO FOR THIS TEMP
IDIVI A,=10 ;TENS IN A, ONES IN B
ADDI A,1
IMULI A,50 ;RADIX50 FOR TENS
ADDI B,1 ;RADIX50 FOR ONES
ADD A,[<XWD 100000,0>+(<RADIX50 0,TEMP>*50*50)]
ADD A,B ;A HAS RADIX50 FOR "TEMPXX"
HRRZ B,PCNT
PUSHJ P,SCOUT ;WRITE A SYMBOL
MOVEI A,0
PUSHJ P,CODOUT
TMNXT: HLRZ PNT,%RVARB(LPSA) ;GET NEXT ONE
TLNN FF,ALLOCT
JRST TMNN
FREBLK ;RELEASE THE SYMBOL TABLE BLOCK
TMNN: MOVE LPSA,PNT ;COPY IT BACK.
JUMPN LPSA,TMPAL ;LOOP
POPJ P,
↑LNKMAK: ; PUT OUT STRING LINK BLOCK, IF NECESSARY
SKIPN TEMP,SLOCALS
JRST SETLNQ
LSH TEMP,-1 ;NUMBER OF STRINGS
HRLZ A,TEMP ;WORD WILL BE #STRINGS,,ADDR OF FIRST
HRRZ LPSA,SLIMS ;SEMANTICS OF FIRST
HRL C,$ADR(LPSA) ;ADDR OF FIRST
TRO A,NOUSAC+USADDR
PUSHJ P,EMITER ;PUT OUT DESCRIPTOR WORD
EMIT (<NOADDR+NOUSAC>) ;LINKAGE WORD -- PUT OUT ZERO
MOVEI B,1 ;STRING LINK.
PUSHJ P,LNKOUT ;THEN A LINKAGE CALL TO LOADER REFERENCING IT
SETLNQ: SKIPN A,LLOCAL
POPJ P, ;NO SETS TO LINK UP EITHER.
MOVNS A ;A WILL BE - # OF SETS,,ADR OF FIRST.
HRRZ LPSA,LLIMS ;SEMANTICS OF FIRST ONE.
HRL C,$ADR(LPSA) ;ADDRESS OF FIRST ONE.
HRRI A,NOUSAC!USADDR
PUSHJ P,EMITER ;PUT IT OUT.
EMIT (NOADDR!NOUSAC) ;FOR THE LINK.
MOVEI B,3 ;SET LINK NUMBER
JRST LNKOUT
SNTP: POPJ P,
COMMENT ⊗REQINI -- USER REQUIRED INITIALIZTIONS⊗
ZERODATA()
INIPDP: 0 ;QSTACK POINTER FOR INITIALIZATIONS
INIMAN: 0 ;FLAG IF INMAIN HAS BEEN CALLED
ENDDATA
DSCR REQINI,REQIN1,REQIN2
CAL PUSHJ
PARM REQINI -- TAKES PROC SEMBLK FROM GENLEF+1
REQIN1 -- PROC SEMBLK IN PNT
REQIN2 -- INITIALIZATION WORD IN A
-- PHASE #,,LOC TO BE PUSHJ'ED TO
DES PUSHES AN INITIALIZATION REQUEST ONTO QSTACK INIPDP. DONES
WILL PUT OUT THE CONTENTS OF THIS QSTACK AS THE INITIALIZATION
REQUEST BLOCK.
⊗
↑REQINI:MOVE PNT,GENLEF+1 ;GET PROCEDURE
↑REQIN1:HLRZ PNT2,%TLINK(PNT);2ND BLOCK
;;#JH# ↓ RHT 9-29-72 TYPO ERROR
HRLZI A,1 ;
CAME A,$NPRMS(PNT2) ;ANY PAPAMS
ERR <THIS PROCEDURE HAS PARAMETERS>,1
PUSHJ P,GETAD
TLNN TBITS,FORWRD!EXTRNL ;IF ONE OF THESE, HARDER
JRST ESYCS
HRRZ C,PCNT
HRLI C,2(C)
EMIT <JRST NOUSAC!USADDR> ;JRST .+2
HRRZ A,PCNT
HRLI A,400000
QPUSH (INIPDP) ;REMEMBER THIS SPOT
EMIT <JRST NOUSAC> ;CALL THE PROCEDURE
POPJ P,
ESYCS: HRRZ A,$ADR(PNT)
HRLI A,400000
REQIN2: QPUSH (INIPDP) ;REMEMBER THE ROUTINE ADDRESS
POPJ P,
COMMENT ⊗ INMAIN - REQUEST INITIALIZATION FOR MAINPR IF NOT ALREADY DONE ⊗
↑INMAIN: SKIPE INIMAN ;ALREADY REQUESTED?
POPJ P, ;YES
SETOM INIMAN ;REQUESTED NOW
HRRZ C,PCNT
HRLI C,2(C) ;FOR JRST .+2
EMIT <JRST NOUSAC!USADDR>
HRL C,PCNT
EXCH C,LIBTAB+RMAINPR ;LIBRARY ENTRY FOR MAINPR
EMIT <JRST NOUSAC!USADDR>
HRR A,PCNT
SUBI A,1
HRLI A,1 ;PHASE 1
JRST REQIN2
SUBTTL DONES -- Storage Allocation Routines -- end of program
DSCR DONES
PRO DONES
DES This is the DONE code. It takes care of any allocation that
must be left until the end, allocates constants,etc.
The order of operations is:
1. Allocate space for any remaining variables, temps, etc.
1aa. Put out block of counters if /K switch is specified.
1aaa. Put out initialization link.
1a. Put out LEAP printnames if any.
2. Allocate space for constants,string constants, and address constants.
3. Output external requests for built-in procedures.
4. Output external requests for run-time (XCALL) routines.
5. Put out rqsts for other programs to be loaded, libraries
to be searched
6. Finish all binary output, and write an end block.
7. Put out the space allocation information block. This is examined
at run time to know how much space need be allocated for various
purposes (strings, leap, array push-down, etc.).
SEE ALOT for variable-allocation code
⊗
;1
↑DONES: PUSHJ P,ALLSTO ;STORE EVERYONE
MOVE A,[XWD 3,3]
PUSHJ P,CREINT
EMIT <SUB P,NOUSAC>
EMIT (<POPJ RP,NOUSAC+NOADDR>) ;RETURN
TLO FF,ALLOCT ;THIS TIME WE DO THINGS RIGHT OFF
PUSHJ P,ALOT
SKIPE ADRTAB ;MUST BE EXHAUSTED AT THIS POINT
ERR <DRYROT -- DONES>,1
REN <
PUSHJ P,LOSET ;DATA TO DATA SEGMENT
>;REN
COMMENT ⊗
If the /K switch was specified, we are now ready to alocate
space for the counters and put out the small data block used
by the runtime routines K.ZERO and K.OUT. The block is linked to
other such blocks via the loader LINK feature, using link
number 5. There will be multiple counter blocks only in the
case of multiple compilations. If there are no counters
inserted, then nothing is put out. The symbolic name
.KOUNT is given to the location of the first counter. The
routine K.OUT needs a file name to write the counters out to
after execution. The filename is set to the name of the listing
file. (they will have different extensions.) The generated
code will look as follows:
--------------------------
| SIXBIT /FILNAM/ |
--------------------------
| LINK to other blocks |
--------------------------
| IOWD 4,.-2 |
--------------------------
| IOWD n,.KOUNT |
--------------------------
| 0 |
--------------------------
.KOUNT: | 1st counter |
--------------------------
| . . . |
| . . . |
--------------------------
| nth counter |
--------------------------
⊗
SKIPE KOUNT ;ARE WE INSERTING COUNTERS
SKIPN KCOUNT ;AND ARE THERE ANY
JRST NOK3 ;NO ON ONE OF THE ABOVE
MOVEI TBITS2,LSTCDB ;GET FILE NAME
MOVE A,CFIL(TBITS2)
TLZ FF,RELOC ;DON'T RELOCATE IT
PUSHJ P,CODOUT ;WRITE IT
MOVEI A,0
PUSHJ P,CODOUT ;PUT OUT A ZERO WORD
MOVEI B,5 ;LINK IT INTO CHAIN 5
PUSHJ P,LNKOUT
MOVE C,PCNT
MOVSI C,-3(C)
EMIT (<XWD -4,NOUSAC!USADDR>) ;IOWD 4,.-2
MOVN A,KCOUNT
HRLZ A,A ;-COUNT
HRR A,PCNT ;.KOUNT-2
ADDI A,1 ; IOWD N,.KOUNT
TLO FF,RELOC ;RELOC PLEASE
PUSHJ P,CODOUT
MOVEI A,0 ;ANOTHER 0
PUSHJ P,CODOUT
PUSHJ P,FRBT ;FORCE OUT CODE BLOCK
HRRZ B,PCNT
MOVE A,[RADIX50 10,.KOUNT] ;DEFINE SYMBOLIC NAME
PUSHJ P,SCOUT ;FOR THE COUNTERS
MOVE A,KCOUNT
ADDM A,PCNT ;LEAVE SPACE FOR THEM
COMMENT ⊗ Now we fix up all counters addresses in
the AOS instructions that have already been output.
⊗
MOVE B,PCNT ;POINT JUST PAST THE COUNTERS
ISK1: MOVEI B,-1(B) ;MOVE POINTER BACK ONE
QPOP (KPDP) ;GET ADDR OF AN AOS
JUMPL A,NOK3 ;THAT'S ALL
HRL B,A ;PREPARE B FOR FBOUT
PUSHJ P,FBOUT ;FIXUP
JRST ISK1 ;ONE MORE TIME
NOK3:
; here put the initialization requests.
SKIPN INIPDP ;ANY ON THE QSTACK?
JRST INI.DN ;NO
MOVEI A,0 ;FOR THE LINK
TLZ FF,RELOC
PUSHJ P,CODOUT
MOVEI B,%INLNK
PUSHJ P,LNKOUT ;PUT OUT THE LINK
TLO FF,RELOC
QBEGIN (INIPDP) ;GET READY TO TAKE SOME OUT
NX.INI: QTAKE (INIPDP) ;TAKE NEXT ENTRY
JRST INI.D1 ;DONE
PUSHJ P,CODOUT ;PUT OUT THE REQUEST
JRST NX.INI
INI.D1: MOVEI A,0
TLZ FF,RELOC
PUSHJ P,CODOUT
INI.DN:
REN <
PUSHJ P,HISET ;BACK TO UPPER SEGMENT TO
>;REN
PUSHJ P,LNKMAK ;MAKE LINKAGE BLOCK
;1A
SKIPE LEAPIS ;ANY LEAP ASKED FOR
;; %AG% GITEMNO NOW CONTAINS THE LEAPIS FLAG
HRROS GITEMNO ;TELL RUNTIMS YES
SKIPN ITMSTK ;ANY DECLARED ITEMS?
JRST CONQN ;NONE
MOVE A,PCNT ;GET PROG. CNTR
MOVEM A,TINIT ;SAVE IT
MOVE A,ITMCNT ;NUMBER OF DECLARED ITEMS(INCLUDES GLOBALS)
TLZ FF,RELOC
PUSHJ P,CODOUT ;PUT IT OUT
MOVE B,ITMBEG ;START OF ITEM QSTACK
LPITMT: QTAKE (ITMSTK) ;GET ITEM,TYPE
JRST PNMOUT ;THROUGH, NO MORE ITEMS
PUSHJ P,CODOUT
JRST LPITMT ;LOOP
PNMOUT:
MOVE A,PCNT
MOVEM A,PINIT
TLZ FF,RELOC
SOS A,PNMSW ;NUMBER OF NAMES.
PUSHJ P,CODOUT ;PUT OUT SOME STUFF.
SKIPN PNMSW
JRST CONQN ;NO PNAMES -- SE ABOUT CONSTANTS.
MOVE B,PNBEG ;THE QTAKE POINTER
ITM1: QTAKE (PNLST)
JRST ITM2 ;ALL DONE.
MOVE PNT,A ;FOR EMITTER
HRRI A,NOUSAC
PUSHJ P,EMITER ; #CHARS,,POINTER TO BYTE POINTER.
JRST ITM1
ITM2:
CONQN:
;2
TLZ FF,RELOC
HRRZ LPSA,CONINT ;VARB-LIKE RING OF CONSTANTS.
JUMPE LPSA,STRGO
REN <
MOVSI D,RECURS ;GET REAL LIVE CONSTANTS FIRST
PUSHJ P,INTLOP
PUSHJ P,LOSET ;SWITCH TO LOWER SEGMENT IF HISW
HRRZ LPSA,CONINT ;NOW GET CONSTANTS WHICH WERE
JUMPE LPSA,STRG1 ; (IF ANY LEFT)
MOVEI D,0 ;UNIQUELY CREATED AS REFERENCE
PUSH P,INTRET ; PARAMS
; PUSHJ P,INTLOP
>;REN
INTLOP:
REN <
TDNE D,$TBITS(LPSA) ;THIS TIME?
JRST GOLEFT ; NO, WAIT FOR LOWER SEGMENT
>;REN
HRLZ B,$ADR(LPSA) ;FIXUP
JUMPE B,NOINT ;NOT USED
HRR B,PCNT
PUSHJ P,FBOUT
MOVE A,$VAL(LPSA) ;VALUE
PUSHJ P,CODOUT ;A WORD FOR IT.
NOINT:
REN <
PUSHJ P,URGCNM ;REMOVE FROM RING
GOLEFT:
>;REN
LEFT ,%RVARB,INTRET
JRST INTLOP ;LOOP UNTIL DONE.
INTRET:
REN <
POPJ P,.+1
STRG1: PUSHJ P,HISET ;BACK TO UPPER
>;REN
STRGO: HRRZ LPSA,CONSTR ;STRING CONSTANT RING.
JUMPE LPSA,BILGO
STRLOP:
MOVS B,$ADR(LPSA) ;FIXUPS
JUMPE B,[SKIPN B,$VAL(LPSA) ;SEE IF STORED IN PRE-LOADED ARRAY
JRST NOSTR ;NOT USED AT ALL.
HRR B,PCNT ;NOW XWD FIXUP,,PCNT
PUSHJ P,FBOUT ;EMIT IT.
JRST PUTIT]
HRLZ B,$ADR(LPSA) ;FIXUP FOR FIRST WORD.
JUMPE B,.+3
HRR B,PCNT
PUSHJ P,FBOUT
HRRZ A,$PNAME(LPSA) ;COUNT OF CHARACTERS.
PUSHJ P,CODOUT
HLLZ B,$ADR(LPSA) ;FIXUP FOR SECOND WORD.
JUMPE B,.+3
HRR B,PCNT
PUSHJ P,FBOUT ;OUTPUT THE FIXUP.
JUMPE A,NOSTR ;IN CASE NULL FLIES BY.
HRLI A,(<POINT 7,0>) ;BYTE POINTER
HRR A,PCNT
ADDI A,1 ;POINT TO .+1
SKIPN B,$VAL(LPSA) ;FIXUP FROM PRE-LOADED ARRAY IF ANY.
JRST .+3
HRR B,A ;THE PCNT FOR ASCII
PUSHJ P,FBOUT ;GO GUYS.
TLO FF,RELOC
PUSHJ P,CODOUT
TLZ FF,RELOC
PUTIT: HRRZ B,$PNAME(LPSA) ;COUNT AGAIN.
ADDI B,4
IDIVI B,5 ;B HAS NUMBER OF WORDS.
HRRZ C,$PNAME+1(LPSA) ;POINTER TO FIRST WORD.
STLL: MOVE A,(C)
PUSHJ P,CODOUT
AOS C
SOJG B,STLL
NOSTR:
LEFT ,%RVARB,BILGO
JRST STRLOP ;LOOP FOR ALL STRINGS.
;3
BILGO:
MOVE LPSA,VARB
CAIE LPSA,RESYM ;IT SHOULD BE HERE
ERR <DRYROT -- DONES>
BILOP: HRRZ B,$ADR(LPSA) ;FIXUP
JUMPE B,BILR
TLNE FF,CREFSW ;CREFFING??
PUSHJ P,CREFDEF ;DEFINE THIS SYMBOL.
PUSHJ P,SOUT ;GENERATE EXTERNAL REQUEST
BILR: LEFT ,%RVARB,LIBGO
JRST BILOP ;LOOP UNTIL DONE
;4
; IF GAG, WILL GET ADDRESSES DIRECTLY (MOVEI)
LIBGO: MOVEI C,0
LIBLOP: SKIPN B,LIBTAB(C) ;FIXUP FOR THIS FCN.
JRST NONT
YESLIB: MOVSS B
MOVE A,LIBNAM(C) ;RADIX50 FOR THIS FCN.
PUSHJ P,SCOUT ;GENERATE THE REQUEST.
NONT: AOS C
CAIE C,LIBNUM
JRST LIBLOP ;LOOP UNTIL DONE.
;5
HRROI TEMP,SALIB+1 ;FAKE STRING DESCRIPTOR FOR SAIL LIBRARY
REN <
SKIPE HISW ;WANT RE-ENTRANT LIBRARY?
HRROI TEMP,SALIBH+1 ;YES
>;REN
POP TEMP,PNAME+1
POP TEMP,PNAME
MOVEI B,LBTAB ;PUT OUT LIBRARY SEARCH
PUSHJ P,PRGOUT ; REQUEST
;6
PUSHJ P,FRBT ;FORCE BINARY.
MOVEI B,FXTAB
PUSHJ P,GBOUT ;AND FIXUPS.
MOVEI B,SMTAB
PUSHJ P,GBOUT ;AND SYMBOLS.
MOVEI B,PRGTAB
PUSHJ P,GBOUT ;AND PROGRAM/LIBRARY REQUESTS
MOVEI B,LBTAB
PUSHJ P,GBOUT
;7
;NOW OUTPUT THE SPACE ALLOCATION BLOCK.
MOVE A,PCNT
MOVEM A,SPCPC ;PCNT FOR SPACE BLOCK.
MOVEM A,SLNKWD ;AND FOR LINK WORD.
HRRZ TEMP,SPCTBL ;NUMBER OF WORDS OF DATA
ADDI A,(TEMP) ;NUMBER OF WORDS IN OBJECT MODULE
MOVEM A,PCNT
MOVEI B,SPCTBL ;SPACE TABLE
AOS TEMP,SPCTBL ;ONE MORE (A ZERO)
MOVEI A,=18
CAIG A,(TEMP)
HRRM A,SPCTBL ;MAKE SURE NO OVERFLOW HAPPENS
PUSHJ P,GBOUT
MOVEI TEMP,2 ;SPACE BLOCK IS TYPE 2
MOVEM TEMP,LNKNM
MOVE B,SDSCRP ;LINK BLOCK
PUSHJ P,GBOUT ;AND LINK (LINK NUMBER 2)
MOVE B,EBDSC ;ASSUME SHOULD WRITE START ADDR, ETC.
TLNN FF,MAINPG ;A STARTING ADDRESS?
MOVE B,EBDSC1 ;NO, NO START ADDR, NO INIT CODE FIXUPS
REN <
PUSHJ P,HISET ;BE SURE PCNT IS IN UPPER SEGMENT
MOVE A,[XWD 5,2] ;ASSUME TWOSEG END BLOCK
MOVE TEMP,[IORM A,STRDDR] ;PUT CONSTANT SYMS INTO HI SEG
SKIPE HISW ;RIGHT?
JRST TSEND ;RIGHT
MOVE TEMP,[ANDCAM A,STRDDR] ;PUT CONSTANT SYMS INTO LOW SEG
MOVE A,[XWD 5,1] ;ONESEG END BLOCK
SUB B,[XWD 1,0] ;ONE FEWER WORDS TO WRITE
TSEND: MOVEM A,PRGBRK-2 ;TO CODE WORD OF LOADER BLOCK
MOVEI A,400000 ;SEGMENT CONTROL BIT
XCT TEMP ;STARTING ADDRESS INTO RIGHT SGMNT
HRRI TEMP,CONSYM+1 ;NOW
XCT TEMP ; PUT S., RPGSW, SAILOR REQUESTS
ADDI TEMP,2 ; INTO PROPER SEGMENT (SEE TOTAL,
XCT TEMP ; UNDER LOADER OUTPUT BLOCKS
ADDI TEMP,4 ; -- END BLOCKS SECTION
XCT TEMP
MOVE A,HCNT ;YES, GET CODE COUNT
MOVEM A,PRGBRK+1 ;LOW SEG BREAK IF TWO SEGMENTS
>;REN
MOVE A,PCNT ;ONLY OR HIGH SEG BREAK
MOVEM A,PRGBRK
PUSHJ P,GBOUT ;WRITE THE END BLOCKS.
POPJ P, ;ALL DONES
COMMENT ⊗MEMORY and LOCATION EXECS, ALSO UINCLL⊗
↑↑ZBITS: SETZM BITS
POPJ P,
↑↑MEMI: SKIPA TBITS,[INTEGR]
↑↑MEMS: MOVE TBITS,BITS
TDNE TBITS,[XWD PROCED!SBSCRP,STRING];ILLEGAL TYPES
ERR <ILLEGAL DATA TYPE FOR MEMORY>,1
PUSHJ P,TYPDEC ;GET PARSE TOKEN
MOVEM A,PARRIG ;PUT IT AWAY
MOVE PNT,GENLEF+1 ;THE EXPRESSION GUY
MOVE SBITS,$SBITS(PNT) ;SEMANTICS OF THE EXPRN
HRRZ TEMP,$TBITS(PNT) ;IT BETTER BE INTEGER
;;#JY# RHT (11-2-72) ↓ TURN OFF SHORT
TRZ TEMP,SHORT ;TTURN OFF SHORT
TLNN SBITS,NEGAT ;AND NOT NEGATIVE
CAIE TEMP,INTEGR
JRST COERCI
TLNE SBITS,INAC ;LOADED?
JRST ITSINA ;YES
TLNE SBITS,ARTEMP ;IF NOT A TEMP
TLNE SBITS,INDXED ;OR INDEXED TEMP
JRST LODIT ;THEN LOAD IT
TLO SBITS,INDXED ;MAKE INDEXED TEMP
MOVEM SBITS,$SBITS(PNT) ;
MOVEM TBITS,$TBITS(PNT) ;
SETZM $VAL(PNT) ;
POPJ P,
LODIT: PUSHJ P,GETAN0 ;GET AN AC
EMIT <HRRZ> ;LOAD IT
MAKTMP: HRLZI SBITS,PTRAC!INDXED
PUSHJ P,GETTEM
HRRZM LPSA,ACKTAB(D) ;REMEMBER IT
HRRM D,$ACNO(LPSA)
MOVEM LPSA,GENRIG
POPJ P,
ITSINA: HRRZ D,$ACNO(PNT) ;GET AC #
PUSHJ P,REMOPA ;IF TEMP, REMOP IT
;;#JV# ↓ (10-20-72) RHT CANNOT USE AC0
JUMPE D,LODIT ;
TLZ SBITS,INAC ;
MOVEM SBITS,$SBITS(PNT) ;THIS WONT BE INAC ANY MORE
JRST MAKTMP ;NICE, NEW TEMP
COERCI: PUSH P,TBITS ;
MOVEI B,INTEGR
GENMOV (GET,POSIT!INSIST!GETD)
PUSHJ P,REMOP ;DONE OLD THING
POP P,TBITS
JRST MAKTMP ;NEW TEMP
↑↑LOCN: MOVE PNT,GENLEF+1 ;
PUSHJ P,GETAD
TLNN SBITS,PTRAC ;IF PTRAC THEN LEAVE ALONE
PUSHJ P,INCOR ;GET THE THING TO CORE
GENMOV (GET,ADDR) ;ADDRESS OF THIS
PUSHJ P,REMOP
MOVEI TBITS,INTEGR
HRLZI SBITS,INAC
GENMOV (MARK,0)
MOVEM PNT,GENRIG
PUSHJ P,TYPDEC
MOVEM A,PARRIG
POPJ P,
↑UINCLL: PUSHJ P,ALLSTO ;FLUSH ACS
XCALL (.UINITS) ;EMIT CALL TO USER INITIALIZATIONS
POPJ P,
DSCR MAKBUK, FREBUK
CAL PUSHJ
PAR current value of SYMTAB
DES MAKBUK allocates a new Semblk, copies current Symtab
bucket list into it; saves a pointer to the old one --
see main SAIL data descriptions for details. This is
how scope is handled, because...
FREBUK deletes this Semblk, restores old pointer. It is
up to somebody else (ALOT) to delete all the local Semblks
which are no longer available via SYMTAB
This junk is unnecessary for STRCON and CONST buckets, since
all such entities are global (one bucket list)
SEE main SAIL data definitions in SAIL
SEE BLOCK, UP1, UP2, etc.
⊗
↑MAKBUK:
GETBLK ;MAKE A NEW BLOCK
EXCH LPSA,SYMTAB ;SYMTAB IS NOW UPDATED
HRLI PNT,(LPSA)
HRR PNT,SYMTAB ;PREPARE TO BLT
HRRZM LPSA,BLKLEN-1(PNT) ;TIE TO OLD ONE
MOVE TEMP,PNT
BLT PNT,BLKLEN-2(TEMP) ;COPY BUCKET
POPJ P,
↑FREBUK:
MOVE LPSA,SYMTAB
HRRZ A,BLKLEN-1(LPSA) ;TIE
MOVEM A,SYMTAB
FREBLK ;RELEASE THE BLOCK
POPJ P,
BEND GENDEC
SUBTTL ERROR MESSAGE EXECS
BEGIN ERRORS
;THE FIRST ROUTINE ALWAYS PRINTS OUT A NEAT MESSAGE....
JOBERR←←42
DEFINE XX (NAME,MESSG,CODE) <
↑ NAME : ERR. 1,[ASCIZ/MESSG/]
TLNN FF,ERSEEN
POPJ P,
IFDIF <CODE><0>,<
;##LN##KVL - MAKES EXECUTION OF BAD CODE HARDER
TLO FF,ERSEEN
HLLOS JOBERR ;CAUSES LOADER TO DELETE EXECUTION (HOPEFULLY)
POPJ P,
>;CODE
>
XX (ER1,<START YOUR PROGRAM WITH BEGIN OR ENTRY - WILL SCAN FOR BEGIN.>,1)
XX (ER2,<BAD ENTRY STATEMENT - WILL SCAN FOR BEGIN.>,1)
XX (ER3,<YOU SEEM TO HAVE USED A , INSTEAD OF A ; BETWEEN DECLARATIONS.>,0)
XX (ER4,<BOGUS IDENTIFIER IN IDENTIFIER LIST.>,1)
XX (ER5,<INSERTING FORGOTTEN SEMI-COLON.>,0)
XX (ER6,<DELETED EXTRA SEMI-COLON.>,0)
XX (ER7,<SYNTAX ERROR. CURRENT STATEMENT OR DECLARATION WILL BE FLUSHED.>,2)
XX (ER8,<SYNTAX ERROR AT END OF EXPRESSION - WILL CHECK FOR PARENTHESES MISMATCH.>,0)
XX (ER15,<ARRAYS SUBSCRIPTING USES BRACKETS! PARENTHESIS REPLACED.>,0)
XX (ER24,<YOU CAN NOT BEGIN A DECLARATION OR STATEMENT LIKE THIS.>,1)
XX (ER33,<NEED AN "UNTIL" AFTER THE STATEMENT OF A "DO ...UNTIL ...">,1)
XX (ER34,<BAD BLOCKING - TOO FEW ENDS.>,1)
XX (ER35,<UNDECLARED ARRAY>,0)
XX (ER36,<MISSING ( INSERTED.>,0)
XX (ER37,<EXTRA ) DELETED.>,0)
XX (ER38,<REQUIRE A BOOLEAN OR AN ALGEBRAIC EXPRESSION HERE.>,1)
XX (ER39,<REQUIRE A CONSTANT ALGEBRAIC EXPRESSION HERE.>,1)
XX (ER40,<INSERTED MISSING ).>,0)
XX (ER41,<YOU CANNOT BEGIN AN EXPRESSION LIKE THIS.>,1)
XX (ER48,<MISSING RIGHT CURLY BRACKET INSERTED.>,0)
XX (ER59,<NEED AN ASSOCIATIVE EXPRESSION HERE.>,1)
XX (ER66,<USE A BEGIN OR A ( AFTER A CASE.>,1)
XX (ER68,<YOU FORGOT TO INCLUDE THE CONTEXT.>,1)
XX (ERTRAP,<QTRAP: ACCORDING TO THE PRODUCTIONS, ITS IMPOSSIBLE FOR TO HIT THIS. SEE A SAIL HACKER>,1);
DEFINE YY (NAME,MESSG) <
↑NAME: PRIN.. 0,[ASCIZ /MESSG
/]
POPJ P,
>
YY (ERR101,<STATEMENT FLUSHED.>)
YY (ERR102,<BLOCK FOUND WHILE FLUSHING STATEMENT - WILL TRY TO PARSE IT.>)
YY (ERR103,<EXTRA ) DELETED.>)
YY (ERR104,<MISSING ) INSERTED.>)
YY (ERR105,<BLOCK END OKAY - FLUSH OF STATEMENT CONTINUES.>)
YY (ERR106,<MISSING ; INSERTED.>)
YY (ERR107,<SORRY - CAN'T CONTINUE.>)
YY (ERR108,<DISREGARD THE ABOVE AND REMEMBER TO USE BRACKETS ON ARRAYS.>)
YY (ERR109,<CVMS TAKES AS AN ARGUMENT A MACRO NAME - PARAMETERS ARE IGNORED>)
YY (ERR110,<DECLARATION TAKES AN IDENTIFIER AS AN ARGUMENT - FLUSH REST OF STATEMENT>)
YY (ERR111,<CHECK_TYPE ONLY TAKES VALID DECLARATIONS OR PARTS OF DECALRATIONS AS ARGUMENTS - FLUSH REST OF STATEMENT>)
XX (ERR112,<BIND OR ? USED INCORRECTLY, WILL BE IGNORED>)
XX (ERR113,<PROPS REQUIRES SINGLE ITEM EXPR AS ARGUMENT>)
XX (ERR114,<PROPS MAY BE ASSIGNED ONLY ARITHMETIC VALUES>)
XX (ERR115,<MISSING ARRAY BOUND-PAIR LIST>)
XX (ERR116,<INVALID SAMEIV SYNTAX>)
XX (ERR117,<INVALID IN_CONTEXT SYNTAX>)
XX (ERR118,<MISUSE OF EXPR_TYPE>)
XX (ERR119,<INVALID CONTEXT ELEMENT SYNTAX>)
XX (ERR120,<ILLEGAL ASSIGNC PARAMETER NAME>)
XX (ERR121,<CONDITIONAL COMPILATION PROBLEM PROBABLY EXTRA ENDC OR ELSEC>)
XX (ERR122,<NOMAC REQUIRES A MACRO NAME WITH NO ARGUMENTS>)
XX (ERR123,<CVPS REQUIRES A LEFT PARENTHESIS HERE>)
XX (ERR124,<ILLEGAL CVPS PARAMETER NAME>)
DSCR SCNBAK,POPBAK,KILPOP,QREM2,QTYPCK;
PRO SCNBAK,POPBAK,KILPOP,QREM1,QREM2,QTYPCK;
DES Error recovery execs:
SCNBAK: backs scanner up by one token.
POPBAK: returns you to the previous production.
KILPOP: returns the production control stack (stack for the ↑EX and ↓↓ stuff)
to its pristine state.
QREM1,QREM2: Called at the end of a block to delete untyped identifiers still left
on the VARB ring.
QTYPCK: Called from PRE in TOTAL. Every time one GENMOVs with CONVRT on, QTYPCK
checks to see if the type bits of either the source or destination are zero in the
rh, and gives the untyped one the type of the other. If the source is undeclared,
then QTYPCK corrects the source, and if the source is a temp, it corrects the
procedure or array that generated the temp.
⊗
;BACKS THE SCANNER UP BY ONE TOKEN
↑SCNBAK: MOVE A,PARLEF
MOVEM A,SAVPAR
MOVE A,GENLEF
MOVEM A,SAVSEM
TLO FF,BAKSCN ;SCANNER IS AHEAD.
POPJ P,
;RETURNS YOU TO THE PREVIOUS PRODUCTION
↑POPBAK: MOVE A,SAVPOP
MOVEM A,-2(P) ;PRODUCTION POINTER.
POPJ P,
;FLUSHS THE PRODUCTION CONTROL STOCK (used for the ↑EX, ↓↓ stuff)
↑KILPOP:
MOVE TEMP,PCSAV ; GET PRODUCTION CONTROL STACK POINTER
KPJ: SKIPGE -1(TEMP) ; IS THIS THE JUMP TO PARSE
JRST KILDUN ; YES, LEAVE IT AND GO HOME
POP TEMP,-1(TEMP) ; NO, GO DOWN ONE
JRST KPJ
KILDUN: MOVEM TEMP,PCSAV
POPJ P,
;CALLED AT THE END OF A BLOCK TO DELETE THE UNTYPED IDENTIFIERS(EXCEPT PROCEDURES)
↑QREM1: SKIPA LPSA,GENLEF+1 ; GET THE BLOCK
↑QREM2: MOVE LPSA,GENLEF+2
JUMPE LPSA,QFIN ; THIS BEGIN HASN'T A BLOCK SEMBLK
QL: HRRZ LPSA,%RVARB(LPSA) ; GO RIGHT ON VARB RING...
QL1: JUMPE LPSA,QFIN ; UNTIL YOU GET TO THE END.
MOVE TBITS,$TBITS(LPSA) ; THE TYPE...
JUMPN TBITS,QL ; IS OKAY...
HRRZ TBITS,%RVARB(LPSA) ;SAVE THE NEXT GUY..........
PUSHJ P,DESTRO ; KILL THE BASTARD!
MOVE LPSA,TBITS
JRST QL1
QFIN: POPJ P,
;DESTROYS AN IDENTIFIER - REMOVES FROM VARB RING - NULLIFIES HASH AND STR RING
↑QDESID:
MOVE LPSA,GENLEF+1 ; GET THE FATED IDENTIFIER
DESTRO:
TLNE FF,CREFSW
PUSHJ P,CREFDEF ; DEFINE WHAT WE'RE KILLING TO CREF
PUSHJ P,URGSTR
PUSHJ P, URGVRB ; UNRING IT
FREBLK (LPSA)
POPJ P,
;CALLED FROM PRE OF GENMOV - CHANGES UNTYPED TO A REASONABLE TYPE
↑QTYPCK:
TRNN TBITS,-1 ; IS THE SOURCE OF UNDECLARED TYPE
JRST QMATCH ; YES, GO GIVE IT THE DESTINATIONS TYPE
TRNE B,-1 ; IS THE DESTINATION UNTYPED
POPJ P, ; NO, GO HOME
HRR B,TBITS ; YES, GIVE IT THE SOURCE TYPE
POPJ P,
QMATCH:
HLR TBITS,$SBITS(PNT) ; GET SOURCE SEMANTICES
HRRM B,$TBITS(PNT) ; GIVE THE SOURCE THE DESTINATION TYPE
TLNN TBITS,INAC!ARTEMP!INUSE ; IS IT A TEMP
JRST .+3 ; NO, GO BACK
HLR TBITS,%TLINK(PNT) ; GET THE ARRAY OR PROCEDURE
HRRM B,$TBITS(TBITS) ; GIVE IT THE GOOD TYPE
HRR TBITS,B ; GIVE TBITS THE GOOD TYPE
POPJ P,
DSCR UNDEC -- Undeclared identifiers;
PRO UNDEC;
DES Declares an identifier globally or locally and modifies symbol table nicely.
When the token I is scanned at the identifier switch areas S1 and EX1 in
HEL, we call UNDEC. Since TYPDEC (called by the scanner) returns I if there are
no type bits on, we may have merely an untyped identifier, so we don't need to
declare it again. Otherwise, we create an empty semblk, then link it on the
appropriate varb ring, hash bucket and string ring for global or local declaration.
We make the assumption that the user has declared something in the global block,
and thus use the block semblk referenced by QQBLK which is loaded at the first
call of the exec BLOCK.
⊗
;ENTERS IDENTIFIER ON LOCAL OR GLOBAL LEVEL
↑UNDEC: SKIPE A,GENLEF ; IF THE THING IS DECLARED...
POPJ P, ; THEN GO BACK ELSE...
HRRZI LPSA,PNAME-1 ;SET UP LPSA WITH IDD'S NAME
ERR <UNDECLARED IDENTIFIER: >,3
SKIPN QQBLK ; IF HE HASN'T DECLARED ANYTHING
ERRPRI <YOUR PROGRAM WILL END FUNNY -- NEXT TIME DECLARE YOUR IDENTIFIERS>
HRRZI A,INTEGR ; SOMETHING SIMPLE TO DECLARE
MOVEM A,BITS
PUSHJ P,ENTERS ; GO MAKE IT
MOVE A,NEWSYM ; GET IT BACK
MOVEM A,GENRIG ; PUT IT OUT
POPJ P, ; RETURN
;;%AC% REMOVE GLOBAL DECLARATION OPTION
IFN 0 <
;The following is how to declare an identifier in the outermost block.
;Social pressures forced its removal from the error recovery, but I
;thought I'd leave it around for a while in case the algorithm is needed
;for another purpose. -kvl
GLOBA: SKIPN PNT,QQBLK ; GET THE HIGHEST BLOCK WITH DECLARATION
JRST LOCA ; WE ARE THE HIGHEST BLOCK
GETBLK NEWSYM ; GET A NEW SEMBLK
MOVE LPSA,NEWSYM
HRROI PNT2,PNAME+1 ; PDP FOR NAME
POP PNT2,$PNAME+1(LPSA)
POP PNT2,$PNAME(LPSA)
PUSHJ P,RNGSTR ; PUT IT ON THE STRING RING
HRRZ PNT,%RVARB(PNT) ; THE FIRST MEMBER OF BLOCK'S VARB RING
HRRZ PNT2,$SBITS(PNT) ; GET THE LEVELS,ZERO THE SBITS
MOVEM PNT2,$SBITS(LPSA)
HRLM LPSA,%RVARB(PNT) ; LPSA ← 1ST
HRRM PNT,%RVARB(LPSA) ; LPSA → 1ST
MOVE PNT,QQBLK ; GET THE HIGHEST BLOCK
HRRM LPSA,%RVARB(PNT) ; BLK → LPSA
HRLM PNT,%RVARB(LPSA) ; BLK ← LPSA
MOVE PNT,HPNT ; GET HASH(BUCK(QQBLK)) INTO B
SUB PNT,SYMTAB ; CORRECT ADDRESS TO...
MOVE C,PNT ; GENERALIZED HPNT FOR LATTER
MOVE PNT2,QQBLK
HRRZ PNT2,%TBUCK(PNT2)
ADD PNT,PNT2 ; ... TO THE OUTER LEVEL
XCT PNT
HRRZ B,LPSA ; B = HASH(BUCK(QQBLK))
HRRZ A,SYMTAB ; INITIALIZE
;GO UP THE BLOCKS, FIXING THE HASH BUCKETS OR HASH CHAINGS THAT USED TO PT TO B
HASHL: MOVE PNT,C ; GET GENERAL HPNT
ADD PNT,A ; CORRECT HPNT TO THIS LEVEL
XCT PNT ; LPSA → HEAD OF HASH CHAIN THIS BUCKET
HRRZ PNT2,LPSA
CAMN B,PNT2 ; DOES B = HASH(BUCK(A)) ?
JRST BUCIT ; YES,GO FIX THIS BUCKET
SKIPN QQFLAG ; NO, FIX THE CHAIN.
JRST UPBUCK ; WE ALREADY FIXED THE CHAIN,GO UP A BLOCK
SETZM QQFLAG ; MAKE SURE WE ONLY DO THIS ONCE
UPCHAI: MOVE PNT,PNT2 ; FIND THE TOP GUY OF THE CHAIN BEFORE QQBLK LEVEL
HRRZ PNT2,%TBUCK(PNT2) ; GO UP
CAME B,PNT2 ; ARE WE AT QQBLK LEVEL YET?
JRST UPCHAI ; NO, GO UP THE CHAIN
HRRZ PNT2,NEWSYM ; GET THE GUY
HRRM PNT2,%TBUCK(PNT) ; TOP-NOT-ON-QQBLK-GUY → UNDECLARED-GUY
HRRM B,%TBUCK(PNT2) ; UNDECLARED-GUY → 1ST-OF-QQBLK-LEVEL-GUY
JRST UPBUCK ; FINE, GO UP A BUCKET
BUCIT: MOVE PNT2,NEWSYM ; WE ARE GOING TO FIX THE BUCKET BY
HRRM LPSA,%TBUCK(PNT2) ; DOING A REGULAR HASH
HRR LPSA,PNT2
TLO PNT,2000
XCT PNT
JRST UPBUCK ; GO UP A BUCKET
UPBUCK: MOVE PNT,QQBLK ; GET THE TOP BUCKET
HRRZ PNT,%TBUCK(PNT)
CAMN A,PNT ; ARE WE AT THE TOP
JRST .+3 ; YES, GO HOME
HRRZ A,BLKLEN-1(A) ; NO, GO UP A BUCKET
JRST HASHL ; NO TRY AGAIN
MOVE PNT,NEWSYM ; PUT OUT, RESTORE, AND QUIT
MOVEM PNT,GENRIG
SETOM QQFLAG
POPJ P,
>; IFN 0
↑↑QQFLAG:0
↑↑QQBLK: 0
DSCR QDEC0,1,2 QARSUB QARDEC QPARM QPRDEC;
PRO QDEC0,QDEC1,QDEC2,QSUBSC,QARDEC,QPARM,QPRDEC.
DES These execs finish the declaration of an undeclared identifier by giving
it a type and appropriate goodies. The QDEC execs determine the type from the token
put in PARRIG by the productions. If we need an array, we count the dimensions with
QSUBSC, install them and put out a temp in QARDEC. If we need a procedure, we get a
second semblk in QDEC, ring on formals in QPARM, install parmeter counts in QPRDEC,
and jrst to QARDEC to generate a temp (we assume all procedures are integer
functions).
⊗
;EXECS TO SET THE TBITS FROM THE PARSE TOKEN
↑QDEC2: MOVEI A,0 ; RIGHT - TOP
JRST .+4
↑QDEC0: SKIPA A,[0] ; RIGHT - ONE DOWN
↑QDEC1: SKIPA A,[1] ; RIGHT - ONE DOWN
SKIPA B,[0] ; LEFT - TOP
MOVEI B,1 ; LEFT - ONE DOWN
HRRZ PNT, PARRIG(A) ; GET IT
MOVEI TBITS,0
CAMN PNT, %ILB ; LABEL
JRST [TRO TBITS,LABEL+FORWRD
ERRPRI <UNDECLARED IDENTIFIER DECLARED A LABEL>
JRST .+15]
CAMN PNT, %ISV ; SET
JRST [TRO TBITS,SET
ERRPRI <UNDECLARED IDENTIFIER DECLARED A SET>
JRST .+13]
CAMN PNT,%ARID ; AN ARRAY
JRST [TLO TBITS, SBSCRP!SAFE
ERRPRI <UNDECLARED IDENTIFIER DECLARED AN ARRAY>
JRST .+11]
CAMN PNT,%PCALL ; A PROCEDURE
JRST .+4
CAMN PNT,%S ; ANOTHER PROCEDURE
JRST .+2
CAMN PNT,%FCALL ; YET ANOTHER PROCEDURE
JRST [MOVE TBITS, [XWD EXTRNL,PROCED!INTEGR]
ERRPRI <UNDECLARED IDENTIFIER DECLARED A INTEGER PROCEDURE>
JRST .+3]
CAMN PNT,%ITV ; ITEMVAR
JRST [TRO TBITS, ITMVAR!INTEGR
ERRPRI <UNDECLARED IDENTIFIER DECLARED AN INTEGER ITEMVAR>
JRST .+1]
; IVB GETS NO BITS
CAME PNT,%S ; DONT TURN ON THE CLASIDX IF S
HRLI PNT,CLSIDX ; ALL VARIABLES ARE CLASS MEMBERS
MOVEM PNT,PARRIG(A) ; PUT IT OUT
MOVE PNT,GENLEF(B) ; GET THE UNDECLARED GUY (from UNDEC)
TLNE TBITS, SBSCRP ; IS IT AN ARRAY
SETZM ,DIMNO ; YES, ZERO THE NUMBER OF DIMENSIONS
TRNE TBITS,PROCED ; IF ITS A PROCEDURE...
JRST [GETBLK ; GET A 2D BLOCK
HRLM LPSA,%TLINK(PNT) ; PUT A PNTR TO IT IN TLINK OF PROC
MOVEW %%VARB,VARB ; SAVE THE CURRENT VARB
SETZM VARB ; INITIALIZE A NEW VARB
JRST .+1]
MOVEM TBITS,$TBITS(PNT) ; GIVE IT ITS TYPE
MOVEM PNT,GENRIG(A)
POPJ P,
%%VARB:0
↑QSUBSC:
AOS ,DIMNO ; COUNT DIMENSIONS
MOVE PNT, GENLEF +1 ; THE EXPRESSION TEMP ..
PUSHJ P,REMOP ; GETS REMOVED
POPJ P,
DIMNO: 0
↑QARDEC:
MOVE PNT2,GENLEF+2 ;GET THE ARRAY (OR PROCEDURE)
MOVE PNT,DIMNO ; GET #OF DIMENSIONS
HRLM PNT,$ACNO(PNT2) ; RECORD IT
MOVEI TBITS,0 ; TYPE IT
MOVEI D,1 ; DUMMY AC NUMBER FOR ...
PUSHJ P,MARKME ; CREATING A TEMP.
HRL PNT,PNT2 ; →ARR (OR →PROC) IN %TLINK( the temp)
MOVEM PNT,GENRIG ; PUT IT OUT
POPJ P,
↑QPARM: MOVE PNT,GENLEF+2 ; GET THE PROCEDURE
HLRZ PNT2,%TLINK(PNT) ; THE SECOND BLOCK
PUSH P,PNT2 ; SAVE IT
MOVE LPSA,GENLEF+1 ; GET THE EXPRESSION
HRRZ TBITS,$TBITS(LPSA) ; GET ITS TYPE
TLO TBITS,VALUE ; MAKE ALL PARAMETERS VALUE...
TRNE TBITS,PROCED ; EXCEPT PROCEDURE EXPRESSIONS
TLC TBITS,VALUE!REFRNC
MOVEM TBITS,BITS
TRNE TBITS,STRING ; IF IT IS A STRING
AOS ,$NPRMS(PNT2) ; INCREMENT STRING PARM COUNT
HLRZ TEMP,$NPRMS(PNT2) ; ALWAYS INCREMENT ARITH PARM COUNT
AOJ TEMP,
HRLM TEMP,$NPRMS(PNT2)
GETBLK ; MAKE A FORMAL
MOVEM TBITS,$TBITS(LPSA) ; GIVE IT A TYPE
PUSHJ P,RNGVRB ; PUT IT ON THE VARB RING
POP P,PNT2 ; GET 2ND BLOCK BACK
SKIPN %TLINK(PNT2) ; IS THIS THE FIRST FORMAL
HRLM LPSA,%TLINK(PNT2) ; YES, PUT A POINTER TO IT IN
; 2D BLOCK OF THE PROCEDURE
MOVE PNT,GENLEF +1 ; GET THE EXPRESSION AND....
JRST REMOP ; KILL IT!!!!! , THEN RETURN QUIETLY
↑QPRDEC:
MOVE PNT,GENLEF+2 ;GET THE PROCEDURE
HLRZ PNT2,%TLINK(PNT) ; GET THE 2D BLOCK
HLRZ TEMP,$NPRMS(PNT2) ; INCREMENT ARITH PARM COUNT
AOJ TEMP,
HRLM TEMP,$NPRMS(PNT2)
HRRZ TEMP,$NPRMS(PNT2) ; STRING PARM COUNT * 2
LSH TEMP,1
HRRM TEMP,$NPRMS(PNT2)
MOVEW VARB,%%VARB ; RESTORE CURRENT VARB
JRST QARDEC ; ASSUME FUNCTION (i.e. make a temp)
BEND
SUBTTL EXECS to handle string constants as comments
BEGIN SCOMM
DSCR SCOMM
PRO SCOMM
DES Remove the damage done by using a string constant
as a comment preceding a statement
⊗
COMMENT ⊗
last prod at S1:
STC → EXEC SCOMM SCAN ¬S1 #Q6
⊗
↑SCOMM1: SKIPA PNT,GENLEF+1 ;SEMANTICS FROM GENLEF+1
↑SCOMM: MOVE PNT,GENLEF ;SEMANTICS OF CONSTANT
PUSHJ P,GETAD ;
TRNN TBITS,STRING ;MUST BE A STRING CONSTANT
JRST [ERR <I THOUGHT IT WAS A STRING COMMENT>,1
POPJ P,]
JRST REMOP
BEND SCOMM
SUBTTL START_CODE (inline) EXECS
BEGIN INLINE
ZERODATA (START_CODE VARIABLES)
↓ACSWCH: 0 ;ACCESS HAS BEEN SEEN (-1) OR NOT (0)
↓CODSEM: 0 ;SEMANTICS OF ADDRESS FIELD (IF VBL)
↓CODVAL: 0 ;VALUE OF ADDRESS, AC, INDEX FIELDS (CONST STUFF)
↓INSTBL: 0 ;→SIXBIT TABLE OF OPCODES, IF HAS BEEN READ IN
↓OPCOD: 0 ;OPCODE OF INSTRUCTION BEING ASSEMBLED
;OPDUN -- on if opcode field has been scanned. Also used as flag
; to EMITER that the instruction going out is a START_CODE
; produced intruction -- avoids optimizations of various forms
↑OPDUN: 0
DATA (START_CODE VARIABLES)
; THIS IS THE ENTER BLOCK FOR THE SIXBIT OPCODE TABLE USED TO
; ALLOW SYMBOLIC OPCODES IN START_CODE INSTRUCTIONS
TNAME: OPNAME
'OPS '
TWORD3: 0
TPPN: OPPPN
ENDDATA
DSCR CODNIT, WRDNIT, ONEWRD, SETSIX, SETOP, CODIND, CODREG, etc.
PRO CODNIT WRDNIT ONEWRD SETSIX SETOP CODIND CODREG CODLIT ERRCOL ERRCOM
DES These routines handle the START_CODE/QUICK_CODE syntax.
The only surprise is a table of SIXBIT opcodes which are read in
when needed. No variable with the same name as one of these opcodes
may be used within a CODE block.
⊗
↑CODNIT:
JRST .+1(B) ;START_CODE CLEARS, QUICK_CODE DOESN'T
PUSHJ P,ALLSTO ;CLEAR THE WORLD
; JRST WRDNIT ;FALL THROUGH
↑WRDNIT:
SETZM ACSWCH ;RESET ACCESS SWITCH
SETZM OPCOD ;OP, AC, INDEX, INDR COLLECTED HERE
SETZM OPDUN
SETZM CODVAL ;OPDUN IS A FLAG, CODVAL IF CONST
SETZM CODSEM ;SEMANTICS OF ADDR IF NON-CONST
;;#JU# RHT (DEL 1 LINE) -- DONT HURT ACKTAB 10-23-72
MOVSI TEMP,INLIN ;SET SPECIAL SCANNER BIT SO THAT
ORM TEMP,SCNWRD ; @ IS TREATED AS A DELIM,
; (DCS -- 8/13/70) PNAME+1 ZEROED
NOCODE: POPJ P,
↑ONEWRD:
SKIPE A,OPCOD
HRRZS CODVAL
OR A,CODVAL
HRL C,A
HLLZS A ;PUT OP CODE,UNRELOC ADDR IN PLACE
SKIPN OPDUN ;WAS ANYTHING SEEN?
JRST NOCODE ; NO, NULL STATEMENT
SETOM OPDUN ;TELL EMITER DOING INLINE CODE
TRO A,NOUSAC!USADDR!NORLC ;ASSUME CONSTANT ADDR FIELD
SKIPN PNT,CODSEM ;WELL, WHICH IS IT?
JRST EMITER ;EMIT IT
MOVE TBITS,$TBITS(PNT) ;GET BITS FOR FXTWO SET
TRC A,USADDR!NORLC!FXTWO ;ASSUME A STRING
;; #JRL# 9-19-72 A STRING ITEMVAR IS NOT A STRING
TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;IF SBSCRP ∨ ¬STRING,
;; #JRL#
TRNN TBITS,STRING ; REVERSE ASSUMPTION
TRZ A,FXTWO
JRST EMITER ;GO EMIT CODE
↑SETSIX:
MOVEI A,0 ;COLLECT SIXBIT
HRRZ TEMP,PNAME ;LENGTH
JUMPE TEMP,.+2 ;IGNORE NULL STRINGS
CAILE TEMP,6 ;MUST BE OPCODE-SIZED
POPJ P, ; NO PRINT NAME, NO SIXBIT
MOVE C,[POINT 6,A]
MOVE LPSA,PNAME+1 ;BYTE POINTER TO STRING
LOOP: SOJL TEMP,LOKSIX ;GOT IT CONVERTED, LOOK IT UP
ILDB D,LPSA ;GET CHAR
SUBI D,40
IDPB D,C ;COLLECT SIXBIT
JRST LOOP
LOKSIX:
Comment ⊗ might be an OPCOD -- will assume it is if it is in
the opcode table. To find out, we may have to read said
table in. Then we will do a linear search to discover
the correct instruction code ⊗
SKIPE B,INSTBL ;TABLE IN CORE?
JRST TABLIN ;YES, ADDRESS IN B
;;#GN# DCS 2-6-72 (1-1) INCLUDE UUO'S, STANFORD UUO'S
EXPO <
SIZZZZ←←700-40
>;EXPO
NOEXPO <
SIZZZZ←←724-40
>;NOEXPO
MOVEI C,SIZZZZ+4 ;SIZE OF TABLE, PLUS BREATHING ROOM
;; #GN#
PUSHJ P,CORGET ;GET SOME SPACE FOR IT
ERR <DRYROT -- INLINE CODE>
SUBI B,1
HRLI B,-SIZZZZ ;IOWD -SIZE,ADDR-1 FOR OP TABLE
MOVEM B,INSTBL ;STORE ITS ADDRESS
MOVEI B+1,0 ;END COMMAND LIST
SETZM TWORD3
MOVE TEMP,[OPPPN]
MOVEM TEMP,TPPN ;RESTORE OPCODE FILE PPN
OPEN 17,[17
OPDEV
0]
ERR <DRYROT -- INLINE CODE>
LOOKUP 17,TNAME
ERR <DRYROT -- INLINE CODE>
INPUT 17,B ;READ THE OP TABLE
RELEASE 17,
TABLIN:
Comment ⊗
B → current table entry (LH IS -COUNT)
A will soon be sixbit for OPcode being sought
⊗
MOVE D,[CAME A,(B)] ;SET UP QUICK SEARCH LOOP
MOVE D+1,[AOBJN B,D] ;ITERATION CONTROL
MOVE D+2,[JRST TSTFND] ;OUT OF ACS
AOJA B,D ;INITIAL ADD
TSTFND: JUMPGE B,UNFNDOP ;SEARCH EXHAUSTED
FNDOPC: SUB B,INSTBL ;GET OP CODE IN OCTAL
;; #GN#
ADDI B,37 ;ADJUST -- FIRST 40 NOT LOADED
;;#GN# (1-1)
MOVEM B,GENRIG ;STORE FOR A WHILE
MOVE TEMP,%OPC ;MARK OPCODE FOUND
MOVEM TEMP,PARRIG ;SAVE FOR PARSER
UNFNDOP: POPJ P,
↑CESSOK: ;THIS EXEC TO DO THE ACCESS CONSTRUCT
MOVE PNT, GENLEF+1 ;GET THE @E
GENMOV ACCESS, GETD ;MAKE SURE THE EXPR IS AVAILABLE
SETOM ACSWCH ;TELL THE CODVBL GUY NOT TO COMPLAIN
POPJ P,
↑CODID: SKIPN PNT,GENLEF+1 ;MUST BE DEFINED
ERR <UNDEFINED INSTRUCTION ELEMENT>,1,FRGET
MOVNI TBITS2,1 ;ASSUME NO OPCODE SEEN YET
HLLOS TEMP,OPDUN ;MARK SOMETHING SEEN
JUMPG TEMP,MAYBOP ;NO OPCODE SEEN, MIGHT BE CNST OPCODE
NONOPC: SKIPN CODSEM ;CHECK TWO ADDRESS FIELDS
SKIPE CODVAL
ERR <TWO ADDRESS FIELDS>,1
MOVEI TBITS2,0 ;OPCODE SEEN PREVIOUSLY
MAYBOP: SETOM OPDUN ;NO MORE OPCODES ALLOWED
PUSHJ P,GETAD
TLNN TBITS,CNST ;CONSTANT?
JRST CODVBL ; NO, MUST BE VARIABLE ADDR FIELD
GENMOV (CONV,INSIST,INTEGR) ;GET INTEGER CONSTANT
MOVE A,$VAL(PNT)
JUMPL TBITS2,STROPC ;OPCODE CONSTANT (ASSUME SO, ANYWAY)
MOVEM A,CODVAL ;NOT OPCODE, SAVE HERE
JRST REMOP ;DON'T NEED CONST ANY MORE
STROPC: ORM A,OPCOD ;NON-DESTRUCTIVE STORE
JRST REMOP ;DON'T NEED SEMANTICS
CODVBL: TLNN SBITS,FIXARR ;ACCEPT CNST-CNST-CNST ARRAY
TLNN SBITS,ARTEMP!STTEMP ; AND VARIABLES
JRST VBLOK
SKIPN ACSWCH ;DON'T COMPLAIN IF ACCESS HAPPENED
ERR <EXPRESSION NOT LEGAL AS INSTRUCTION ADDRESS>,1
VBLOK: MOVEM PNT,CODSEM ;SAVE SEMANTICS
POPJ P,
↑SETOP: HLLOS TEMP,OPDUN ;SET SOMETHING SEEN
JUMPL TEMP,TWOOP ;TWO OPCODES
SETOM OPDUN ;MARK OPCODE DONE
MOVE A,GENLEF
DPB A,[POINT 9,OPCOD,8] ;OPCOD POSITION
POPJ P,
TWOOP: ERR <TWO OPCODES>,1,FRGET
↑CODIND:
HLLOS OPDUN ;MARK SOMETHING SEEN
MOVSI TEMP,20 ;INDIRECT BIT
ORM TEMP,OPCOD ;PUT IN OPCOD WORD
FRGET: POPJ P,
↑CODREG:
HLLOS OPDUN
SKIPN PNT,GENLEF+1 ;MUST BE A CONSTANT
ERR <NON-CONSTANT AC FIELD>,1,REMOP
GENMOV (CONV,GETD!INSIST,INTEGR)
TLNN TBITS,CNST ;MUST BE A CONSTANT
ERR <NON-CONSTANT AC FIELD>,1,REMOP
MOVE TEMP,$VAL(PNT) ;GET ITS VALUE
DPB TEMP,[POINT 4,OPCOD,12] ;DEPOSIT IN AC FIELD
JRST REMOP
↑CODX: HLLOS OPDUN
SKIPN PNT,GENLEF+1 ;MUST BE A CONSTANT
ERR <NON-CONSTANT INDEX FIELD>,1,REMOP
GENMOV (CONV,GETD!INSIST,INTEGR)
TLNN TBITS,CNST
ERR <NON-CONSTANT INDEX FIELD>,1,REMOP
MOVE TEMP,$VAL(PNT)
DPB TEMP,[POINT 4,OPCOD,17] ;INDEX FIELD
JRST REMOP
↑CODLIT:
HLLOS OPDUN
SKIPN PNT,GENLEF+1
ERR <NON-CONSTANT LITERAL>,1,REMOP
MOVE TBITS,$TBITS(PNT)
TLNN TBITS,CNST
ERR <NON-CONSTANT LITERAL>,1,REMOP
SKIPN CODVAL ;CHECK FOR TWO ADDRESS FIELDS
SKIPE CODSEM
ERR <TWO ADDRESS FIELDS>,1,REMOP
CODBK: MOVEM PNT,CODSEM
MOVSI TEMP,INLIN ;TURN SPECIAL SCANNING BIT
ORM TEMP,SCNWRD ;BACK ON
POPJ P,
↑LITOFF: ;TURN OFF SPECIAL @ SCANNING BIT IN SCNWRD
; (CALLED WHEN SCANNING LITERALS, AND WHEN LEAVING A
; START_CODE BLOCK)
MOVSI TEMP,INLIN
ANDCAM TEMP,SCNWRD
POPJ P,
↑ERRCOL:
ERR <UNDEFINED LABEL OR BAD SYNTAX>,1
POPJ P,
↑ERRCOM:
ERR <COMMA USED IN WRONG MANNER>,1
POPJ P,
BEND INLINE
SUBTTL COUNTER SYSTEM EXECS
BEGIN COUNT
DSCR KOUNT1,KOUNT2,KOUNT3,KOUNT4,KOUNT5 -- INSERT A COUNTER
PRO KOUNT1 KOUNT2 KOUNT3 KOUNT4 KOUNT5
DES These exec routines insert a counter into the code and a
marker into the output listing. They are NO-OP's unless the
/K switch is specified. As a listing file is necessary for /K,
it is not necessary to check SCANWD for listing. KOUNT2 will
someday do the right thing for multiple labels. KOUNT3 , KOUNT4,
and KOUNT5 insert a different marker for counters in expressions.
The multiplicity of routines for expression counters comes from
the necessity of having the counter immediately after the reserved
word in order for the analysis routine to work right.
⊗
↑KOUNT6: SKIPA C,[","] ;SHOULD FOLLOW ","
↑KOUNT5: MOVEI C,"(" ;SHOULD FOLLOW "("
JRST KOUNT4+1
↑KOUNT3: SKIPA C,["N"] ;SHOULD FOLLOW "THEN"
↑KOUNT4: MOVEI C,"E" ;SHOULD FOLLOW "ELSE"
MOVEI B,3 ;MARKER IS BETA (β)
MOVEI D,LSTOU1 ;USE THIS LIST ROUTINE
JRST KOUNT1+2
↑KOUNT2: ;EVENTUALLY, CHECK FOR MULTIPLE LABELS
↑KOUNT1: MOVEI B,2 ;MARKER IS ALPHA (α)
MOVEI D,LSTOUT ;USE THIS ROUTINE
SKIPN KOUNT ;ARE WE INSERTING COUNTERS
POPJ P, ;NO
MOVE A,[AOS 0]
PUSHJ P,CODOUT ;PUT THE ADD INSTR INTO THE CODE
AOS KCOUNT ;COUNT THE COUNTERS
MOVE A,PCNT
SUBI A,1
QPUSH (KPDP,) ;SAVE ADDRESS OF AOS
MOVEI A,177 ;PUT A MARKER INTO
PUSHJ P,(D) ; THE LIST FILE
MOVEI C,177 ;NEEDED IN CASE WE'RE CALLING LSTOU1
MOVE A,B ;GET THE CHARACTER FOR THE MARK
PUSHJ P,(D)
POPJ P,
BEND COUNT
SUBTTL ARRAY DECLARATION AND INDEXING EXECS